TTG: Move MatchGroup Origin field and MatchGroupTc to GHC.Hswip/romes/ttg-matchgroup-origin

12 files changed, 46 insertions, 40 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 76699dc4f3..6f57eb5304 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -1292,10 +1292,17 @@ instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where
 ************************************************************************
 -}
 
-type instance XMG         GhcPs b = NoExtField
-type instance XMG         GhcRn b = NoExtField
+type instance XMG         GhcPs b = Origin
+type instance XMG         GhcRn b = Origin
 type instance XMG         GhcTc b = MatchGroupTc
 
+data MatchGroupTc
+  = MatchGroupTc
+       { mg_arg_tys :: [Scaled Type]  -- Types of the arguments, t1..tn
+       , mg_res_ty  :: Type    -- Type of the result, tr
+       , mg_origin  :: Origin  -- Origin (Generated vs FromSource)
+       } deriving Data
+
 type instance XXMatchGroup (GhcPass _) b = DataConCantHappen
 
 type instance XCMatch (GhcPass _) b = EpAnn [AddEpAnn]
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
index b93d87a9b3..30009ef400 100644
--- a/compiler/GHC/Hs/Syn/Type.hs
+++ b/compiler/GHC/Hs/Syn/Type.hs
@@ -192,7 +192,7 @@ lhsCmdTopType :: LHsCmdTop GhcTc -> Type
 lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty
 
 matchGroupTcType :: MatchGroupTc -> Type
-matchGroupTcType (MatchGroupTc args res) = mkVisFunTys args res
+matchGroupTcType (MatchGroupTc args res _) = mkVisFunTys args res
 
 syntaxExprType :: SyntaxExpr GhcTc -> Type
 syntaxExprType (SyntaxExprTc e _ _) = hsExprType e
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index e5bcd5959f..9d4e733375 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -200,7 +200,7 @@ unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 unguardedRHS an loc rhs = [L (noAnnSrcSpan loc) (GRHS an [] rhs)]
 
 type AnnoBody p body
-  = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ NoExtField
+  = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ Origin
     , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnL
     , Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA
     )
@@ -209,9 +209,8 @@ mkMatchGroup :: AnnoBody p body
              => Origin
              -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
              -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
-mkMatchGroup origin matches = MG { mg_ext = noExtField
-                                 , mg_alts = matches
-                                 , mg_origin = origin }
+mkMatchGroup origin matches = MG { mg_ext = origin
+                                 , mg_alts = matches }
 
 mkLamCaseMatchGroup :: AnnoBody p body
                     => Origin
@@ -257,7 +256,7 @@ mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e paren_wct)
 mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
 mkHsAppTypes = foldl' mkHsAppType
 
-mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField)
+mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
         => [LPat (GhcPass p)]
         -> LHsExpr (GhcPass p)
         -> LHsExpr (GhcPass p)
@@ -880,7 +879,7 @@ mkPatSynBind name details lpat dir anns = PatSynBind noExtField psb
 -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
 -- considered infix.
 isInfixFunBind :: forall id1 id2. UnXRec id2 => HsBindLR id1 id2 -> Bool
-isInfixFunBind (FunBind { fun_matches = MG _ matches _ })
+isInfixFunBind (FunBind { fun_matches = MG _ matches })
   = any (isInfixMatch . unXRec @id2) (unXRec @id2 matches)
 isInfixFunBind _ = False
 
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index 253bd1b60d..e7dbebb5f9 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -501,7 +501,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdCase _ exp match) env_ids = do
     stack_id <- newSysLocalDs Many stack_ty
     (match', core_choices)
       <- dsCases ids local_vars stack_id stack_ty res_ty match
-    let MG{ mg_ext = MatchGroupTc _ sum_ty } = match'
+    let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match'
         in_ty = envStackType env_ids stack_ty
 
     core_body <- dsExpr (HsCase noExtField exp match')
@@ -544,7 +544,7 @@ dsCmd ids local_vars stack_ty res_ty
       (match', core_choices)
         <- dsCases ids local_vars' stack_id stack_ty' res_ty match
 
-      let MG{ mg_ext = MatchGroupTc _ sum_ty } = match'
+      let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match'
           in_ty = envStackType env_ids stack_ty'
           discrims = map nlHsVar arg_ids
       (discrim_vars, matching_code)
@@ -756,8 +756,8 @@ dsCases :: DsCmdEnv                               -- arrow combinators
                 CoreExpr)                         -- desugared choices
 dsCases ids local_vars stack_id stack_ty res_ty
         (MG { mg_alts = L l matches
-            , mg_ext = MatchGroupTc arg_tys _
-            , mg_origin = origin }) = do
+            , mg_ext = MatchGroupTc arg_tys _ origin
+            }) = do
 
   -- Extract and desugar the leaf commands in the case, building tuple
   -- expressions that will (after tagging) replace these leaves
@@ -805,8 +805,8 @@ dsCases ids local_vars stack_id stack_ty res_ty
     Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$>
       dsExpr (HsLamCase EpAnnNotUsed LamCase
         (MG { mg_alts = noLocA []
-            , mg_ext = MatchGroupTc [Scaled Many void_ty] res_ty
-            , mg_origin = Generated }))
+            , mg_ext = MatchGroupTc [Scaled Many void_ty] res_ty Generated
+            }))
 
       -- Replace the commands in the case with these tagged tuples,
       -- yielding a HsExpr Id we can feed to dsExpr.
@@ -816,8 +816,8 @@ dsCases ids local_vars stack_id stack_ty res_ty
   -- Note that we replace the MatchGroup result type by sum_ty,
   -- which is the type of matches'
   return (MG { mg_alts = L l matches'
-             , mg_ext = MatchGroupTc arg_tys sum_ty
-             , mg_origin = origin },
+             , mg_ext = MatchGroupTc arg_tys sum_ty origin
+             },
           core_choices)
 
 {-
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 9d87eec5e0..bc287f433c 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -732,8 +732,8 @@ dsDo ctx stmts
                            (MG { mg_alts = noLocA [mkSimpleMatch
                                                     LambdaExpr
                                                     [mfix_pat] body]
-                               , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty
-                               , mg_origin = Generated })
+                               , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty Generated
+                               })
         mfix_pat     = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats
         body         = noLocA $ HsDo body_ty
                                 ctx (noLocA (rec_stmts ++ [ret_stmt]))
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index 5c45d9b705..1780c30755 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -762,8 +762,8 @@ JJQC 30-Nov-1997
 -}
 
 matchWrapper ctxt scrs (MG { mg_alts = L _ matches
-                             , mg_ext = MatchGroupTc arg_tys rhs_ty
-                             , mg_origin = origin })
+                           , mg_ext = MatchGroupTc arg_tys rhs_ty origin
+                           })
   = do  { dflags <- getDynFlags
         ; locn   <- getSrcSpanDs
 
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index d3b7978856..b6604a9d76 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -879,11 +879,14 @@ instance ( HiePass p
          , ToHie (LocatedA (body (GhcPass p)))
          ) => ToHie (MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))) where
   toHie mg = case mg of
-    MG{ mg_alts = (L span alts) , mg_origin = origin} ->
+    MG{ mg_alts = (L span alts) } ->
       local (setOrigin origin) $ concatM
         [ locOnly (locA span)
         , toHie alts
         ]
+    where origin = case hiePass @p of
+             HieRn -> mg_ext mg
+             HieTc -> mg_origin $ mg_ext mg
 
 setOrigin :: Origin -> NodeOrigin -> NodeOrigin
 setOrigin FromSource _ = SourceInfo
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index 0239bf759b..70489c0048 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -1216,7 +1216,7 @@ rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContext GhcRn
              -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
              -> MatchGroup GhcPs (LocatedA (body GhcPs))
              -> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)
-rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_origin = origin })
+rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_ext = origin })
          -- see Note [Empty MatchGroups]
   = do { whenM ((null ms &&) <$> mustn't_be_empty) (addErr (emptyCaseErr ctxt))
        ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index a4eff74ea4..6e4166d36d 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -339,7 +339,7 @@ tcCmdMatchLambda :: CmdEnv
                  -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc))
 tcCmdMatchLambda env
                  ctxt
-                 mg@MG { mg_alts = L l matches }
+                 mg@MG { mg_alts = L l matches, mg_ext = origin }
                  (cmd_stk, res_ty)
   = do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk
 
@@ -349,7 +349,7 @@ tcCmdMatchLambda env
 
        ; let arg_tys' = map unrestricted arg_tys
              mg' = mg { mg_alts = L l matches'
-                      , mg_ext = MatchGroupTc arg_tys' res_ty }
+                      , mg_ext = MatchGroupTc arg_tys' res_ty origin }
 
        ; return (mkWpCastN co, mg') }
   where
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index 9c838785ac..9646cfeace 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -223,7 +223,7 @@ tcMatches :: (AnnoBody body ) => TcMatchCtxt body
           -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
 
 tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
-                                  , mg_origin = origin })
+                                  , mg_ext = origin })
   | null matches  -- Deal with case e of {}
     -- Since there are no branches, no one else will fill in rhs_ty
     -- when in inference mode, so we must do it ourselves,
@@ -232,8 +232,8 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
        ; pat_tys <- mapM scaledExpTypeToType pat_tys
        ; rhs_ty  <- expTypeToType rhs_ty
        ; return (MG { mg_alts = L l []
-                    , mg_ext = MatchGroupTc pat_tys rhs_ty
-                    , mg_origin = origin }) }
+                    , mg_ext = MatchGroupTc pat_tys rhs_ty origin
+                    }) }
 
   | otherwise
   = do { umatches <- mapM (tcCollectingUsage . tcMatch ctxt pat_tys rhs_ty) matches
@@ -242,8 +242,8 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
        ; pat_tys  <- mapM readScaledExpType pat_tys
        ; rhs_ty   <- readExpType rhs_ty
        ; return (MG { mg_alts   = L l matches'
-                    , mg_ext    = MatchGroupTc pat_tys rhs_ty
-                    , mg_origin = origin }) }
+                    , mg_ext    = MatchGroupTc pat_tys rhs_ty origin
+                    }) }
 
 -------------
 tcMatch :: (AnnoBody body) => TcMatchCtxt body
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index a306a3967e..7a3ca9e42a 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -830,15 +830,13 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
                     L (getLoc lpat) $
                     HsCase noExtField (nlHsVar scrutinee) $
                     MG{ mg_alts = L (l2l $ getLoc lpat) cases
-                      , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty
-                      , mg_origin = Generated
+                      , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty Generated
                       }
              body' = noLocA $
                      HsLam noExtField $
                      MG{ mg_alts = noLocA [mkSimpleMatch LambdaExpr
                                                          args body]
-                       , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty
-                       , mg_origin = Generated
+                       , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty Generated
                        }
              match = mkMatch (mkPrefixFunRhs (L loc patsyn_id)) []
                              (mkHsLams (rr_tv:res_tv:univ_tvs)
@@ -846,8 +844,7 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
                              (EmptyLocalBinds noExtField)
              mg :: MatchGroup GhcTc (LHsExpr GhcTc)
              mg = MG{ mg_alts = L (l2l $ getLoc match) [match]
-                    , mg_ext = MatchGroupTc [] res_ty
-                    , mg_origin = Generated
+                    , mg_ext = MatchGroupTc [] res_ty Generated
                     }
              matcher_arity = length req_theta + 3
              -- See Note [Pragmas for pattern synonyms]
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 6fa47f8b64..b5fbea49ed 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -674,14 +674,14 @@ zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
             -> MatchGroup GhcTc (LocatedA (body GhcTc))
             -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
 zonkMatchGroup env zBody (MG { mg_alts = L l ms
-                             , mg_ext = MatchGroupTc arg_tys res_ty
-                             , mg_origin = origin })
+                             , mg_ext = MatchGroupTc arg_tys res_ty origin
+                             })
   = do  { ms' <- mapM (zonkMatch env zBody) ms
         ; arg_tys' <- zonkScaledTcTypesToTypesX env arg_tys
         ; res_ty'  <- zonkTcTypeToTypeX env res_ty
         ; return (MG { mg_alts = L l ms'
-                     , mg_ext = MatchGroupTc arg_tys' res_ty'
-                     , mg_origin = origin }) }
+                     , mg_ext = MatchGroupTc arg_tys' res_ty' origin
+                     }) }
 
 zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
           => ZonkEnv