Make PatSyn immutable

Provoked by #19074, this patch makes GHC.Core.PatSyn.PatSyn
immutable, by recording only the *Name* of the matcher and
builder rather than (as currently) the *Id*.

See Note [Keep Ids out of PatSyn] in GHC.Core.PatSyn.

Updates haddock submodule.

7 files changed, 69 insertions, 71 deletions

diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index b61d265583..62c6cb218a 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -320,7 +320,7 @@ tcValBinds top_lvl binds sigs thing_inside
                  do { thing <- thing_inside
                        -- See Note [Pattern synonym builders don't yield dependencies]
                        --     in GHC.Rename.Bind
-                    ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns
+                    ; patsyn_builders <- mapM (tcPatSynBuilderBind prag_fn) patsyns
                     ; let extra_binds = [ (NonRecursive, builder)
                                         | builder <- patsyn_builders ]
                     ; return (extra_binds, thing) }
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 4f0fc23af3..2d5a49f2e6 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -569,7 +569,7 @@ tcExpr (HsStatic fvs expr) res_ty
 ************************************************************************
 -}
 
-tcExpr expr@(RecordCon { rcon_con_name = L loc con_name
+tcExpr expr@(RecordCon { rcon_con = L loc con_name
                        , rcon_flds = rbinds }) res_ty
   = do  { con_like <- tcLookupConLike con_name
 
@@ -580,22 +580,19 @@ tcExpr expr@(RecordCon { rcon_con_name = L loc con_name
         ; let arity = conLikeArity con_like
               Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau
 
-        ; case conLikeWrapId_maybe con_like of {
-               Nothing -> nonBidirectionalErr (conLikeName con_like) ;
-               Just con_id ->
+        ; checkTc (conLikeHasBuilder con_like) $
+          nonBidirectionalErr (conLikeName con_like)
 
-     do { rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds
+        ; rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds
                    -- It is currently not possible for a record to have
                    -- multiplicities. When they do, `tcRecordBinds` will take
                    -- scaled types instead. Meanwhile, it's safe to take
                    -- `scaledThing` above, as we know all the multiplicities are
                    -- Many.
 
-        ; let rcon_tc = RecordConTc
-                           { rcon_con_like = con_like
-                           , rcon_con_expr = mkHsWrap con_wrap con_expr }
+        ; let rcon_tc = mkHsWrap con_wrap con_expr
               expr' = RecordCon { rcon_ext = rcon_tc
-                                , rcon_con_name = L loc con_id
+                                , rcon_con = L loc con_like
                                 , rcon_flds = rbinds' }
 
         ; ret <- tcWrapResultMono expr expr' actual_res_ty res_ty
@@ -610,7 +607,7 @@ tcExpr expr@(RecordCon { rcon_con_name = L loc con_name
         -- via a new `HoleSort`.  But that seems too much work.
         ; checkMissingFields con_like rbinds arg_tys
 
-        ; return ret } } }
+        ; return ret }
   where
     orig = OccurrenceOf con_name
 
@@ -837,8 +834,8 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
 
         -- Check that we're not dealing with a unidirectional pattern
         -- synonym
-        ; unless (isJust $ conLikeWrapId_maybe con1)
-                 (nonBidirectionalErr (conLikeName con1))
+        ; checkTc (conLikeHasBuilder con1) $
+          nonBidirectionalErr (conLikeName con1)
 
         -- STEP 3    Note [Criteria for update]
         -- Check that each updated field is polymorphic; that is, its type
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 84e391ee50..fa642131c1 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -773,7 +773,7 @@ tc_infer_id id_name
                    | Just (expr, ty) <- patSynBuilderOcc ps
                    -> return (expr, ty)
                    | otherwise
-                   -> nonBidirectionalErr id_name
+                   -> failWithTc (nonBidirectionalErr id_name)
 
              AGlobal (ATyCon ty_con)
                -> fail_tycon global_env ty_con
@@ -855,10 +855,9 @@ check_naughty lbl id
   | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)
   | otherwise                  = return ()
 
-nonBidirectionalErr :: Outputable name => name -> TcM a
-nonBidirectionalErr name = failWithTc $
-    text "non-bidirectional pattern synonym"
-    <+> quotes (ppr name) <+> text "used in an expression"
+nonBidirectionalErr :: Outputable name => name -> SDoc
+nonBidirectionalErr name = text "non-bidirectional pattern synonym"
+                           <+> quotes (ppr name) <+> text "used in an expression"
 
 {-
 Note [Linear fields generalization]
diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs
index 52a5592d67..588f209377 100644
--- a/compiler/GHC/Tc/TyCl/Build.hs
+++ b/compiler/GHC/Tc/TyCl/Build.hs
@@ -33,7 +33,6 @@ import GHC.Types.Id.Make
 import GHC.Core.Class
 import GHC.Core.TyCon
 import GHC.Core.Type
-import GHC.Types.Id
 import GHC.Types.SourceText
 import GHC.Tc.Utils.TcType
 import GHC.Core.Multiplicity
@@ -171,7 +170,7 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
 
 ------------------------------------------------------
 buildPatSyn :: Name -> Bool
-            -> (Id,Bool) -> Maybe (Id, Bool)
+            -> PatSynMatcher -> PatSynBuilder
             -> ([InvisTVBinder], ThetaType) -- ^ Univ and req
             -> ([InvisTVBinder], ThetaType) -- ^ Ex and prov
             -> [Type]                       -- ^ Argument types
@@ -179,7 +178,7 @@ buildPatSyn :: Name -> Bool
             -> [FieldLabel]                 -- ^ Field labels for
                                             --   a record pattern synonym
             -> PatSyn
-buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
+buildPatSyn src_name declared_infix matcher@(_, matcher_ty,_) builder
             (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
             pat_ty field_labels
   = -- The assertion checks that the matcher is
@@ -202,7 +201,7 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
              arg_tys pat_ty
              matcher builder field_labels
   where
-    ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id
+    ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ matcher_ty
     ([pat_ty1, cont_sigma, _], _)      = tcSplitFunTys tau
     (ex_tvs1, prov_theta1, cont_tau)   = tcSplitSigmaTy (scaledThing cont_sigma)
     (arg_tys1, _) = (tcSplitFunTys cont_tau)
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 593226db5c..43388472d7 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -104,13 +104,12 @@ recoverPSB (PSB { psb_id = L _ name
                         ([mkTyVarBinder SpecifiedSpec alphaTyVar], []) ([], [])
                         [] -- Arg tys
                         alphaTy
-                        (matcher_id, True) Nothing
+                        (matcher_name, matcher_ty, True) Nothing
                         []  -- Field labels
        where
          -- The matcher_id is used only by the desugarer, so actually
          -- and error-thunk would probably do just as well here.
-         matcher_id = mkLocalId matcher_name Many $
-                      mkSpecForAllTys [alphaTyVar] alphaTy
+         matcher_ty = mkSpecForAllTys [alphaTyVar] alphaTy
 
 {- Note [Pattern synonym error recovery]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -700,17 +699,17 @@ tc_patsyn_finish lname dir is_infix lpat' prag_fn
            ppr pat_ty
 
        -- Make the 'matcher'
-       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' prag_fn
+       ; (matcher, matcher_bind) <- tcPatSynMatcher lname lpat' prag_fn
                                          (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts)
                                          (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts)
                                          (args, arg_tys)
                                          pat_ty
 
        -- Make the 'builder'
-       ; builder_id <- mkPatSynBuilderId dir lname
-                                         univ_tvs req_theta
-                                         ex_tvs   prov_theta
-                                         arg_tys pat_ty prag_fn
+       ; builder <- mkPatSynBuilder dir lname
+                                    univ_tvs req_theta
+                                    ex_tvs   prov_theta
+                                    arg_tys pat_ty
 
        -- Make the PatSyn itself
        ; let patSyn = mkPatSyn (unLoc lname) is_infix
@@ -718,7 +717,7 @@ tc_patsyn_finish lname dir is_infix lpat' prag_fn
                         (ex_tvs, prov_theta)
                         arg_tys
                         pat_ty
-                        matcher_id builder_id
+                        matcher builder
                         field_labels
 
        -- Selectors
@@ -745,7 +744,7 @@ tcPatSynMatcher :: Located Name
                 -> ([TcTyVar], [TcType], ThetaType, [EvTerm])
                 -> ([LHsExpr GhcTc], [TcType])
                 -> TcType
-                -> TcM ((Id, Bool), LHsBinds GhcTc)
+                -> TcM (PatSynMatcher, LHsBinds GhcTc)
 -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn
 tcPatSynMatcher (L loc name) lpat prag_fn
                 (univ_tvs, req_theta, req_ev_binds, req_dicts)
@@ -823,7 +822,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn
        ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
        ; traceTc "tcPatSynMatcher" (ppr matcher_bind)
 
-       ; return ((matcher_prag_id, is_unlifted), matcher_bind) }
+       ; return ((matcher_name, matcher_sigma, is_unlifted), matcher_bind) }
 
 mkPatSynRecSelBinds :: PatSyn
                     -> [FieldLabel]  -- ^ Visible field labels
@@ -845,15 +844,14 @@ isUnidirectional ExplicitBidirectional{} = False
 ************************************************************************
 -}
 
-mkPatSynBuilderId :: HsPatSynDir a -> Located Name
-                  -> [InvisTVBinder] -> ThetaType
-                  -> [InvisTVBinder] -> ThetaType
-                  -> [Type] -> Type
-                  -> TcPragEnv
-                  -> TcM (Maybe (Id, Bool))
-mkPatSynBuilderId dir (L _ name)
+mkPatSynBuilder :: HsPatSynDir a -> Located Name
+                -> [InvisTVBinder] -> ThetaType
+                -> [InvisTVBinder] -> ThetaType
+                -> [Type] -> Type
+                -> TcM PatSynBuilder
+mkPatSynBuilder dir (L _ name)
                   univ_bndrs req_theta ex_bndrs prov_theta
-                  arg_tys pat_ty prag_fn
+                  arg_tys pat_ty
   | isUnidirectional dir
   = return Nothing
   | otherwise
@@ -866,44 +864,47 @@ mkPatSynBuilderId dir (L _ name)
                               mkPhiTy theta $
                               mkVisFunTysMany arg_tys $
                               pat_ty
-             builder_id     = mkExportedVanillaId builder_name builder_sigma
-              -- See Note [Exported LocalIds] in GHC.Types.Id
-
-             builder_id'    = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id
-             prags          = lookupPragEnv prag_fn name
-             -- See Note [Pragmas for pattern synonyms]
-
-       ; builder_prag_id <- addInlinePrags builder_id' prags
-       ; return (Just (builder_prag_id, need_dummy_arg)) }
+       ; return (Just (builder_name, builder_sigma, need_dummy_arg)) }
 
-tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn
+tcPatSynBuilderBind :: TcPragEnv
+                    -> PatSynBind GhcRn GhcRn
                     -> TcM (LHsBinds GhcTc)
 -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn
-tcPatSynBuilderBind (PSB { psb_id = L loc name
-                         , psb_def = lpat
-                         , psb_dir = dir
-                         , psb_args = details })
+tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
+                                 , psb_def = lpat
+                                 , psb_dir = dir
+                                 , psb_args = details })
   | isUnidirectional dir
   = return emptyBag
 
   | Left why <- mb_match_group       -- Can't invert the pattern
   = setSrcSpan (getLoc lpat) $ failWithTc $
     vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
-                 <+> quotes (ppr name) <> colon)
+                 <+> quotes (ppr ps_name) <> colon)
               2 why
          , text "RHS pattern:" <+> ppr lpat ]
 
   | Right match_group <- mb_match_group  -- Bidirectional
-  = do { patsyn <- tcLookupPatSyn name
+  = do { patsyn <- tcLookupPatSyn ps_name
        ; case patSynBuilder patsyn of {
            Nothing -> return emptyBag ;
              -- This case happens if we found a type error in the
              -- pattern synonym, recovered, and put a placeholder
              -- with patSynBuilder=Nothing in the environment
 
-           Just (builder_id, need_dummy_arg) ->  -- Normal case
+           Just (builder_name, builder_ty, need_dummy_arg) ->  -- Normal case
     do { -- Bidirectional, so patSynBuilder returns Just
-         let match_group' | need_dummy_arg = add_dummy_arg match_group
+         let pat_ty = patSynResultType patsyn
+             builder_id = modifyIdInfo (`setLevityInfoWithType` pat_ty) $
+                          mkExportedVanillaId builder_name builder_ty
+                         -- See Note [Exported LocalIds] in GHC.Types.Id
+             prags = lookupPragEnv prag_fn ps_name
+             -- See Note [Pragmas for pattern synonyms]
+             -- Keyed by the PatSyn Name, not the (internal) builder name
+
+       ; builder_id <- addInlinePrags builder_id prags
+
+       ; let match_group' | need_dummy_arg = add_dummy_arg match_group
                           | otherwise      = match_group
 
              bind = FunBind { fun_id      = L loc (idName builder_id)
@@ -911,10 +912,12 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name
                             , fun_ext     = emptyNameSet
                             , fun_tick    = [] }
 
-             sig = completeSigFromId (PatSynCtxt name) builder_id
+             sig = completeSigFromId (PatSynCtxt ps_name) builder_id
 
        ; traceTc "tcPatSynBuilderBind {" $
-         ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id)
+         vcat [ ppr patsyn
+              , ppr builder_id <+> dcolon <+> ppr (idType builder_id)
+              , ppr prags ]
        ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind)
        ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
        ; return builder_binds } } }
@@ -926,7 +929,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name
     mb_match_group
        = case dir of
            ExplicitBidirectional explicit_mg -> Right explicit_mg
-           ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat)
+           ImplicitBidirectional -> fmap mk_mg (tcPatToExpr ps_name args lpat)
            Unidirectional -> panic "tcPatSynBuilderBind"
 
     mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
@@ -934,7 +937,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name
           where
             builder_args  = [L loc (VarPat noExtField (L loc n))
                             | L loc n <- args]
-            builder_match = mkMatch (mkPrefixFunRhs (L loc name))
+            builder_match = mkMatch (mkPrefixFunRhs ps_lname)
                                     builder_args body
                                     (noLoc (EmptyLocalBinds noExtField))
 
@@ -953,13 +956,12 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name
 
 patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, TcSigmaType)
 patSynBuilderOcc ps
-  | Just (builder_id, add_void_arg) <- patSynBuilder ps
+  | Just (_, builder_ty, add_void_arg) <- patSynBuilder ps
   , let builder_expr = HsConLikeOut noExtField (PatSynCon ps)
-        builder_ty   = idType builder_id
   = Just $
     if add_void_arg
-    then ( builder_expr   -- still just return builder_expr; the void# arg is added
-                          -- by dsConLike in the desugarer
+    then ( builder_expr   -- still just return builder_expr; the void# arg
+                          -- is added by dsConLike in the desugarer
          , tcFunResultTy builder_ty )
     else (builder_expr, builder_ty)
 
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs-boot b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot
index 22e5c9fb86..844a4c394d 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs-boot
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot
@@ -12,5 +12,6 @@ tcPatSynDecl :: PatSynBind GhcRn GhcRn
              -> TcPragEnv
              -> TcM (LHsBinds GhcTc, TcGblEnv)
 
-tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc)
+tcPatSynBuilderBind :: TcPragEnv -> PatSynBind GhcRn GhcRn
+                    -> TcM (LHsBinds GhcTc)
 
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 5bd1fe490d..76b101c679 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -889,10 +889,10 @@ zonkExpr env (ExplicitList ty wit exprs)
    where zonkWit env Nothing    = return (env, Nothing)
          zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
 
-zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds })
-  = do  { new_con_expr <- zonkExpr env (rcon_con_expr ext)
+zonkExpr env expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds })
+  = do  { new_con_expr <- zonkExpr env con_expr
         ; new_rbinds   <- zonkRecFields env rbinds
-        ; return (expr { rcon_ext  = ext { rcon_con_expr = new_con_expr }
+        ; return (expr { rcon_ext  = new_con_expr
                        , rcon_flds = new_rbinds }) }
 
 zonkExpr env (RecordUpd { rupd_flds = rbinds