something good in sightwip/expand-do

18 files changed, 66 insertions, 47 deletions

diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 008469b458..42704d1e8e 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -45,7 +45,7 @@ module GHC.Hs.Utils(
   mkSimpleMatch, unguardedGRHSs, unguardedRHS,
   mkMatchGroup, mkLamCaseMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
   mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
-  mkHsDictLet, mkHsLams,
+  mkHsDictLet, mkHsLams, mkHsLamDoExp,
   mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns, mkHsWrapPat, mkHsWrapPatCo,
   mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
   mkHsCmdIf, mkConLikeTc,
@@ -271,7 +271,17 @@ mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
         -> LHsExpr (GhcPass p)
 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))
   where
-    matches = mkMatchGroup Generated
+    matches = mkMatchGroup (Generated OtherExpansion)
+                           (noLocA [mkSimpleMatch LambdaExpr pats' body])
+    pats' = map (parenthesizePat appPrec) pats
+
+mkHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
+        => [LPat (GhcPass p)]
+        -> LHsExpr (GhcPass p)
+        -> LHsExpr (GhcPass p)
+mkHsLamDoExp pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))
+  where
+    matches = mkMatchGroup (Generated DoExpansion)
                            (noLocA [mkSimpleMatch LambdaExpr pats' body])
     pats' = map (parenthesizePat appPrec) pats
 
@@ -599,7 +609,7 @@ nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
 nlList   :: [LHsExpr GhcPs] -> LHsExpr GhcPs
 
 -- AZ:Is this used?
-nlHsLam match = noLocA (HsLam noExtField (mkMatchGroup Generated (noLocA [match])))
+nlHsLam match = noLocA (HsLam noExtField (mkMatchGroup (Generated OtherExpansion) (noLocA [match])))
 nlHsPar e     = noLocA (gHsPar e)
 
 -- nlHsIf should generate if-expressions which are NOT subject to
@@ -608,7 +618,7 @@ nlHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
 nlHsIf cond true false = noLocA (HsIf noAnn cond true false)
 
 nlHsCase expr matches
-  = noLocA (HsCase noAnn expr (mkMatchGroup Generated (noLocA matches)))
+  = noLocA (HsCase noAnn expr (mkMatchGroup (Generated OtherExpansion) (noLocA matches)))
 nlList exprs          = noLocA (ExplicitList noAnn exprs)
 
 nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
@@ -867,7 +877,7 @@ spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))
 mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
                 -> LHsExpr GhcPs -> LHsBind GhcPs
 mkSimpleGeneratedFunBind loc fun pats expr
-  = L (noAnnSrcSpan loc) $ mkFunBind Generated (L (noAnnSrcSpan loc) fun)
+  = L (noAnnSrcSpan loc) $ mkFunBind (Generated OtherExpansion) (L (noAnnSrcSpan loc) fun)
               [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) pats expr
                        emptyLocalBinds]
 
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index cc757a94e3..8e33d900f4 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -811,7 +811,7 @@ 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 ManyTy void_ty] res_ty Generated
+            , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty (Generated OtherExpansion)
             }))
 
       -- Replace the commands in the case with these tagged tuples,
diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs
index 40771d4998..ff127267d1 100644
--- a/compiler/GHC/HsToCore/Docs.hs
+++ b/compiler/GHC/HsToCore/Docs.hs
@@ -346,10 +346,10 @@ subordinates env instMap decl = case decl of
     data_fams = do
       DataFamInstDecl { dfid_eqn =
         (FamEqn { feqn_tycon = L l _
-               , feqn_rhs   = defn } :: FamEqn GhcRn (HsDataDefn GhcRn))} <- unLoc <$> cid_datafam_insts d
+               , feqn_rhs   = defn })} <- unLoc <$> cid_datafam_insts d
       [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn
     ty_fams = do
-      TyFamInstDecl { tfid_eqn = (FamEqn { feqn_tycon = L l _ } :: FamEqn GhcRn (LHsType GhcRn)) } <- unLoc <$> cid_tyfam_insts d
+      TyFamInstDecl { tfid_eqn = (FamEqn { feqn_tycon = L l _ }) } <- unLoc <$> cid_tyfam_insts d
       [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ]
     in data_fams ++ ty_fams
 
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 88704a9e1e..2ac542e1b4 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -763,7 +763,7 @@ dsDo ctx stmts
                            (MG { mg_alts = noLocA [mkSimpleMatch
                                                     LambdaExpr
                                                     [mfix_pat] body]
-                               , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty Generated
+                               , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty (Generated OtherExpansion)
                                })
         mfix_pat     = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats
         body         = noLocA $ HsDo body_ty
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index d27f522a8d..4663a02aaa 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -831,10 +831,10 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches'
                       $ replicate (length (grhssGRHSs m)) initNablas
 
     is_pat_syn_match :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool
-    is_pat_syn_match Generated (L _ (Match _ _ [l_pat] _)) = isPatSyn l_pat
+    is_pat_syn_match (Generated _) (L _ (Match _ _ [l_pat] _)) = isPatSyn l_pat
     is_pat_syn_match _ _ = False
     non_wc :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool
-    non_wc Generated (L _ (Match _ _ ([L _ (WildPat _)]) _)) = False
+    non_wc (Generated _) (L _ (Match _ _ ([L _ (WildPat _)]) _)) = False
     non_wc _ _ = True
 
 matchEquations  :: HsMatchContext GhcRn
diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs
index fc411f491b..32af01df03 100644
--- a/compiler/GHC/HsToCore/Match/Constructor.hs
+++ b/compiler/GHC/HsToCore/Match/Constructor.hs
@@ -20,7 +20,7 @@ import {-# SOURCE #-} GHC.HsToCore.Match ( match )
 import GHC.Hs
 import GHC.HsToCore.Binds
 import GHC.Core.ConLike
-import GHC.Types.Basic ( Origin(..) )
+import GHC.Types.Basic ( Origin(..), GenReason (..) )
 import GHC.Tc.Utils.TcType
 import GHC.Core.Multiplicity
 import GHC.HsToCore.Monad
@@ -167,7 +167,7 @@ matchOneConLike vars ty mult (eqn1 :| eqns)   -- All eqns for a single construct
                        return ( wrapBinds (tvs `zip` tvs1)
                               . wrapBinds (ds  `zip` dicts1)
                               . mkCoreLets ds_bind
-                              , eqn { eqn_orig = Generated
+                              , eqn { eqn_orig = Generated OtherExpansion
                                     , eqn_pats = conArgPats val_arg_tys args ++ pats }
                               )
               shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs
index 033acb557a..29bc39b121 100644
--- a/compiler/GHC/HsToCore/Pmc/Utils.hs
+++ b/compiler/GHC/HsToCore/Pmc/Utils.hs
@@ -14,7 +14,7 @@ module GHC.HsToCore.Pmc.Utils (
 
 import GHC.Prelude
 
-import GHC.Types.Basic (Origin(..), isGenerated)
+import GHC.Types.Basic (Origin(..), isGenerated, isDoExpansionGenerated)
 import GHC.Driver.Session
 import GHC.Hs
 import GHC.Core.Type
@@ -109,7 +109,7 @@ arrowMatchContextExhaustiveWarningFlag = \ case
 -- exhaustiveness check).
 isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool
 isMatchContextPmChecked _ origin LambdaExpr -- It is likely that this is generated by expanding do stmts
-  = isGenerated origin
+  = isDoExpansionGenerated origin
 isMatchContextPmChecked dflags origin kind
   | isGenerated origin
   = False
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 22022397f9..dc13e5744f 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -906,7 +906,7 @@ instance ( HiePass p
 
 setOrigin :: Origin -> NodeOrigin -> NodeOrigin
 setOrigin FromSource _ = SourceInfo
-setOrigin Generated _ = GeneratedInfo
+setOrigin (Generated _) _ = GeneratedInfo
 
 instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where
     toHie (L sp psb) = concatM $ case psb of
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index 4992ebf309..42f58e79e5 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -55,7 +55,7 @@ import GHC.Types.SourceText ( SourceText(..), IntegralLit )
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Misc
-import GHC.Types.Basic  ( TopLevelFlag(..), Origin(Generated) )
+import GHC.Types.Basic  ( TopLevelFlag(..), Origin(Generated), GenReason (OtherExpansion) )
 import GHC.Data.List.SetOps ( removeDupsOn )
 import GHC.Data.Maybe ( whenIsJust )
 import GHC.Driver.Session
@@ -715,6 +715,6 @@ genFunBind :: LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]
            -> HsBind GhcRn
 genFunBind fn ms
   = FunBind { fun_id = fn
-            , fun_matches = mkMatchGroup Generated (wrapGenSpan ms)
+            , fun_matches = mkMatchGroup (Generated OtherExpansion) (wrapGenSpan ms)
             , fun_ext = emptyNameSet
             }
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 7ada3093e5..41b005205c 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -2301,7 +2301,7 @@ mkFunBindSE arity loc fun pats_and_exprs
 mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
              -> LHsBind GhcPs
 mkRdrFunBind fun@(L loc _fun_rdr) matches
-  = L (na2la loc) (mkFunBind Generated fun matches)
+  = L (na2la loc) (mkFunBind  (Generated OtherExpansion) fun matches)
 
 -- | Make a function binding. If no equations are given, produce a function
 -- with the given arity that uses an empty case expression for the last
@@ -2329,7 +2329,7 @@ mkRdrFunBindEC :: Arity
                -> [LMatch GhcPs (LHsExpr GhcPs)]
                -> LHsBind GhcPs
 mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
-  = L (na2la loc) (mkFunBind Generated fun matches')
+  = L (na2la loc) (mkFunBind  (Generated OtherExpansion) fun matches')
  where
    -- Catch-all eqn looks like
    --     fmap _ z = case z of {}
@@ -2353,7 +2353,7 @@ mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
 mkRdrFunBindSE :: Arity -> LocatedN RdrName ->
                     [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
 mkRdrFunBindSE arity fun@(L loc fun_rdr) matches
-  = L (na2la loc) (mkFunBind Generated fun matches')
+  = L (na2la loc) (mkFunBind  (Generated OtherExpansion) fun matches')
  where
    -- Catch-all eqn looks like
    --     compare _ _ = error "Void compare"
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index fb9a0630d2..615e763d5e 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -1276,7 +1276,7 @@ desugarRecordUpd record_expr possible_parents rbnds res_ty
              ds_expr = HsLet noExtField noHsTok let_binds noHsTok (L gen case_expr)
 
              case_expr :: HsExpr GhcRn
-             case_expr = HsCase noExtField record_expr (mkMatchGroup Generated (wrapGenSpan matches))
+             case_expr = HsCase noExtField record_expr (mkMatchGroup (Generated OtherExpansion) (wrapGenSpan matches))
              matches :: [LMatch GhcRn (LHsExpr GhcRn)]
              matches = map make_pat relevant_cons
 
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index 8e97476211..a92e015ac7 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -79,7 +79,7 @@ import GHC.Types.Fixity (LexicalFixity(..))
 import GHC.Types.Name
 import GHC.Types.Id
 import GHC.Types.SrcLoc
-import GHC.Types.Basic (Origin (..))
+import GHC.Types.Basic (Origin (..), GenReason (..))
 import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
@@ -1256,7 +1256,7 @@ expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn pat e)): lstmts)
          expand_stmts <- expand_do_stmts do_or_lc lstmts
          return $ mkHsApps  (genLHsVar bindMName) -- (Prelude.>>=)
                             [ e
-                            , mkHsLam [pat] (noLocA $ PopSrcSpan expand_stmts)  -- (\ x -> stmts')
+                            , mkHsLamDoExp [pat] (noLocA $ PopSrcSpan expand_stmts)  -- (\ x -> stmts')
                             ]
 
 expand_do_stmts do_or_lc (L _ (LetStmt _ bnds) : lstmts) =
@@ -1298,7 +1298,7 @@ expand_do_stmts do_or_lc
   do expand_stmts <- expand_do_stmts do_or_lc lstmts
      return $ mkHsApps (genLHsVar bindMName)                            -- (Prelude.>>=)
                       [ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr           -- (mfix (do block))
-                      , mkHsLam [ mkBigLHsVarPatTup all_ids ]                --        (\ x ->
+                      , mkHsLamDoExp [ mkBigLHsVarPatTup all_ids ]                --        (\ x ->
                                        (noLocA $ PopSrcSpan expand_stmts)      --           stmts')
                       ]
   where
@@ -1316,7 +1316,7 @@ expand_do_stmts do_or_lc
     do_block     :: LHsExpr GhcRn
     do_block     = wrapGenSpan $ HsDo noExtField (DoExpr Nothing) $ do_stmts
     mfix_expr    :: LHsExpr GhcRn
-    mfix_expr    = mkHsLam [ wrapGenSpan (LazyPat noExtField $ mkBigLHsVarPatTup all_ids) ] $ do_block
+    mfix_expr    = mkHsLamDoExp [ wrapGenSpan (LazyPat noExtField $ mkBigLHsVarPatTup all_ids) ] $ do_block
                              -- LazyPat becuase we do not want to eagerly evaluate the pattern
                              -- and potentially loop forever
 
@@ -1391,7 +1391,7 @@ mk_failable_lexpr_tcm pat lexpr fail_op =
      ; if b
           -- don't decorate with fail statement if
           -- 1) the pattern is irrefutable
-       then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr))
+       then return $ mkHsLamDoExp [pat] (noLocA (PopSrcSpan lexpr))
        else mk_fail_lexpr pat lexpr fail_op
      }
 
@@ -1401,7 +1401,7 @@ mk_failable_lexpr_tcm pat lexpr fail_op =
 mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
 mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
   do  dflags <- getDynFlags
-      return $ noLocA (HsLam noExtField $ mkMatchGroup Generated            -- \
+      return $ noLocA (HsLam noExtField $ mkMatchGroup (Generated DoExpansion)            -- \
                       (noLocA [ mkHsCaseAlt pat (noLocA $ PopSrcSpan lexpr) --   pat -> expr
                               , mkHsCaseAlt nlWildPatName                   --   _   -> fail "fail pattern"
                                 (noLocA $ genHsApp fail_op
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 29cfbafa74..87c511ae18 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -1623,8 +1623,9 @@ checkGADT conlike ex_tvs arg_tys = \case
     has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs
 
 -- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't depend on type checking
+-- does depend on the type environment however
 isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> TcM Bool
-isIrrefutableHsPatRn _ is_strict pat =
+isIrrefutableHsPatRn tc_env is_strict pat =
   do traceTc "isIrrefutableHsPatRn" empty
      goL pat
   where
@@ -1662,9 +1663,7 @@ isIrrefutableHsPatRn _ is_strict pat =
                       ; traceTc "isIrrefutableHsPatRn ATyCon" (vcat [ ppr tycon
                                                       , ppr (isNewTyCon tycon)
                                                       , ppr (tcHasFixedRuntimeRep tycon)])
-                      ; let b' = (isJust (tyConSingleDataCon_maybe tycon)
-                                          || isNewTyCon tycon
-                                          || tcHasFixedRuntimeRep tycon)
+                      ; let b' = isJust (tyConSingleDataCon_maybe tycon)
                       ; return (b && b') }
               id@(AnId _) -> pprPanic "isIrrefutableHsPatRn AnId" (ppr id)
               (AConLike cl) ->
@@ -1676,9 +1675,7 @@ isIrrefutableHsPatRn _ is_strict pat =
                             traceTc "isIrrefutableHsPatRn AConLike" (vcat [ ppr tycon
                                                                      , ppr (isNewTyCon tycon)
                                                                      , ppr (tcHasFixedRuntimeRep tycon)] )
-                            let b' = (isJust (tyConSingleDataCon_maybe tycon)
-                                              || isNewTyCon tycon
-                                              || tcHasFixedRuntimeRep tycon)
+                            let b' = isJust (tyConSingleDataCon_maybe tycon)
                             return (b && b')
                        PatSynCon con -> do traceTc "isIrrefutableHsPatRn AConLike" (ppr con)
                                            return False -- conservative
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index e28ba6f24f..d9bb768fb2 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -1961,7 +1961,7 @@ lookupName is_type_name s
 getThSpliceOrigin :: TcM Origin
 getThSpliceOrigin = do
   warn <- goptM Opt_EnableThSpliceWarnings
-  if warn then return FromSource else return Generated
+  if warn then return FromSource else return (Generated OtherExpansion)
 
 
 getThing :: TH.Name -> TcM TcTyThing
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index caae46ce36..02296c9207 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -2166,7 +2166,7 @@ mkDefMethBind loc dfun_id clas sel_id dm_name
                                       , tyConBinderForAllTyFlag tcb /= Inferred ]
               rhs  = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys
               bind = L (noAnnSrcSpan loc)
-                    $ mkTopFunBind Generated fn
+                    $ mkTopFunBind (Generated OtherExpansion) fn
                         [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
 
         ; liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Filling in method body"
@@ -2410,4 +2410,3 @@ instDeclCtxt2 dfun_ty
 inst_decl_ctxt :: SDoc -> SDoc
 inst_decl_ctxt doc = hang (text "In the instance declaration for")
                         2 (quotes doc)
-
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index c61c471bac..d40f673069 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -811,13 +811,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 Generated
+                      , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty  (Generated OtherExpansion)
                       }
              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 Generated
+                       , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty  (Generated OtherExpansion)
                        }
              match = mkMatch (mkPrefixFunRhs (L loc (idName patsyn_id))) []
                              (mkHsLams (rr_tv:res_tv:univ_tvs)
@@ -825,7 +825,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 Generated
+                    , mg_ext = MatchGroupTc [] res_ty  (Generated OtherExpansion)
                     }
              matcher_arity = length req_theta + 3
              -- See Note [Pragmas for pattern synonyms]
@@ -958,7 +958,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
            Unidirectional -> panic "tcPatSynBuilderBind"
 
     mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
-    mk_mg body = mkMatchGroup Generated (noLocA [builder_match])
+    mk_mg body = mkMatchGroup  (Generated OtherExpansion) (noLocA [builder_match])
           where
             builder_args  = [L (na2la loc) (VarPat noExtField (L loc n))
                             | L loc n <- args]
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index 8e7b3b8c39..88de871f47 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -928,7 +928,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
     -- make the binding: sel (C2 { fld = x }) = x
     --                   sel (C7 { fld = x }) = x
     --    where cons_w_field = [C2,C7]
-    sel_bind = mkTopFunBind Generated sel_lname alts
+    sel_bind = mkTopFunBind (Generated OtherExpansion) sel_lname alts
       where
         alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname)
                                            [] unit_rhs]
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index 1f73c82028..c047e4daf2 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/compiler/GHC/Types/Basic.hs
@@ -35,7 +35,8 @@ module GHC.Types.Basic (
         FunctionOrData(..),
 
         RecFlag(..), isRec, isNonRec, boolToRecFlag,
-        Origin(..), isGenerated,
+        Origin(..), isGenerated, isDoExpansionGenerated,
+        GenReason(..),
 
         RuleName, pprRuleName,
 
@@ -582,17 +583,29 @@ instance Binary RecFlag where
 ************************************************************************
 -}
 
+data GenReason = DoExpansion
+               | OtherExpansion
+               deriving (Eq, Data)
+
+instance Outputable GenReason where
+  ppr DoExpansion  = text "DoExpansion"
+  ppr OtherExpansion  = text "OtherExpansion"
+
 data Origin = FromSource
-            | Generated
+            | Generated GenReason
             deriving( Eq, Data )
 
 isGenerated :: Origin -> Bool
-isGenerated Generated = True
+isGenerated (Generated _) = True
 isGenerated FromSource = False
 
+isDoExpansionGenerated :: Origin -> Bool
+isDoExpansionGenerated (Generated DoExpansion) = True
+isDoExpansionGenerated _ = False
+
 instance Outputable Origin where
   ppr FromSource  = text "FromSource"
-  ppr Generated   = text "Generated"
+  ppr (Generated r)  = text "Generated" <+> ppr r
 
 {-
 ************************************************************************