summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Hs/Utils.hs20
-rw-r--r--compiler/GHC/HsToCore/Arrows.hs2
-rw-r--r--compiler/GHC/HsToCore/Docs.hs4
-rw-r--r--compiler/GHC/HsToCore/Expr.hs2
-rw-r--r--compiler/GHC/HsToCore/Match.hs4
-rw-r--r--compiler/GHC/HsToCore/Match/Constructor.hs4
-rw-r--r--compiler/GHC/HsToCore/Pmc/Utils.hs4
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs2
-rw-r--r--compiler/GHC/Rename/Utils.hs4
-rw-r--r--compiler/GHC/Tc/Deriv/Generate.hs6
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Match.hs12
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs11
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs2
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs3
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs8
-rw-r--r--compiler/GHC/Tc/TyCl/Utils.hs2
-rw-r--r--compiler/GHC/Types/Basic.hs21
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
{-
************************************************************************
View Lorry Controller Status