summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Hs/Expr.hs32
-rw-r--r--compiler/GHC/Hs/Instances.hs2
-rw-r--r--compiler/GHC/Hs/Utils.hs10
-rw-r--r--compiler/GHC/HsToCore/Arrows.hs4
-rw-r--r--compiler/GHC/HsToCore/Expr.hs8
-rw-r--r--compiler/GHC/HsToCore/ListComp.hs8
-rw-r--r--compiler/GHC/HsToCore/Utils.hs6
-rw-r--r--compiler/GHC/Parser/PostProcess.hs2
-rw-r--r--compiler/GHC/Rename/Expr.hs105
-rw-r--r--compiler/GHC/Rename/Pat.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Match.hs17
-rw-r--r--compiler/GHC/Tc/Module.hs4
-rw-r--r--compiler/GHC/ThToHs.hs4
-rw-r--r--compiler/Language/Haskell/Syntax/Expr.hs107
-rw-r--r--utils/check-exact/ExactPrint.hs4
-rw-r--r--utils/check-exact/Utils.hs15
16 files changed, 165 insertions, 165 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 011a527d53..d0c5dbef0c 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -186,7 +186,6 @@ data HsWrap hs_syn = HsWrap HsWrapper -- the wrapper
deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn)
-type instance HsDoRn (GhcPass _) = GhcRn
type instance HsBracketRn (GhcPass _) = GhcRn
type instance PendingRnSplice' (GhcPass _) = PendingRnSplice
type instance PendingTcSplice' (GhcPass _) = PendingTcSplice
@@ -797,7 +796,7 @@ hsExprNeedsParens prec = go
go (HsMultiIf{}) = prec > topPrec
go (HsLet{}) = prec > topPrec
go (HsDo _ sc _)
- | isComprehensionContext sc = False
+ | isDoComprehensionContext sc = False
| otherwise = prec > topPrec
go (ExplicitList{}) = False
go (RecordUpd{}) = False
@@ -1185,7 +1184,7 @@ ppr_cmd (HsCmdLet _ binds cmd)
= sep [hang (text "let") 2 (pprBinds binds),
hang (text "in") 2 (ppr cmd)]
-ppr_cmd (HsCmdDo _ (L _ stmts)) = pprDo ArrowExpr stmts
+ppr_cmd (HsCmdDo _ (L _ stmts)) = pprArrowExpr stmts
ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)
= hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
@@ -1448,8 +1447,6 @@ type instance XApplicativeArgOne GhcTc = FailOperator GhcTc
type instance XApplicativeArgMany (GhcPass _) = NoExtField
type instance XXApplicativeArg (GhcPass _) = NoExtCon
-type instance ApplicativeArgStmCtxPass _ = GhcRn
-
instance (Outputable (StmtLR (GhcPass idL) (GhcPass idL) (LHsExpr (GhcPass idL))),
Outputable (XXParStmtBlock (GhcPass idL) (GhcPass idR)))
=> Outputable (ParStmtBlock (GhcPass idL) (GhcPass idR)) where
@@ -1562,16 +1559,20 @@ pprBy (Just e) = text "by" <+> ppr e
pprDo :: (OutputableBndrId p, Outputable body,
Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA
)
- => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc
+ => HsDoFlavour -> [LStmt (GhcPass p) body] -> SDoc
pprDo (DoExpr m) stmts =
ppr_module_name_prefix m <> text "do" <+> ppr_do_stmts stmts
pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts
-pprDo ArrowExpr stmts = text "do" <+> ppr_do_stmts stmts
pprDo (MDoExpr m) stmts =
ppr_module_name_prefix m <> text "mdo" <+> ppr_do_stmts stmts
pprDo ListComp stmts = brackets $ pprComp stmts
pprDo MonadComp stmts = brackets $ pprComp stmts
-pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt
+
+pprArrowExpr :: (OutputableBndrId p, Outputable body,
+ Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA
+ )
+ => [LStmt (GhcPass p) body] -> SDoc
+pprArrowExpr stmts = text "do" <+> ppr_do_stmts stmts
ppr_module_name_prefix :: Maybe ModuleName -> SDoc
ppr_module_name_prefix = \case
@@ -1868,12 +1869,15 @@ matchContextErrString PatSyn = panic "matchContextErrString"
matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard"
-matchContextErrString (StmtCtxt GhciStmtCtxt) = text "interactive GHCi command"
-matchContextErrString (StmtCtxt (DoExpr m)) = prependQualified m (text "'do' block")
-matchContextErrString (StmtCtxt ArrowExpr) = text "'do' block"
-matchContextErrString (StmtCtxt (MDoExpr m)) = prependQualified m (text "'mdo' block")
-matchContextErrString (StmtCtxt ListComp) = text "list comprehension"
-matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension"
+matchContextErrString (StmtCtxt (ArrowExpr)) = text "'do' block"
+matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour
+
+matchDoContextErrString :: HsDoFlavour -> SDoc
+matchDoContextErrString GhciStmtCtxt = text "interactive GHCi command"
+matchDoContextErrString (DoExpr m) = prependQualified m (text "'do' block")
+matchDoContextErrString (MDoExpr m) = prependQualified m (text "'mdo' block")
+matchDoContextErrString ListComp = text "list comprehension"
+matchDoContextErrString MonadComp = text "monad comprehension"
pprMatchInCtxt :: (OutputableBndrId idR, Outputable body)
=> Match (GhcPass idR) body -> SDoc
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 87f1ceafff..d2f69cc7bb 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -366,6 +366,8 @@ deriving instance Data (HsStmtContext GhcPs)
deriving instance Data (HsStmtContext GhcRn)
deriving instance Data (HsStmtContext GhcTc)
+deriving instance Data HsDoFlavour
+
deriving instance Data (HsMatchContext GhcPs)
deriving instance Data (HsMatchContext GhcRn)
deriving instance Data (HsMatchContext GhcTc)
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 590cf87793..a0f4fa4c07 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -299,11 +299,11 @@ nlParPat p = noLocA (gParPat p)
mkHsIntegral :: IntegralLit -> HsOverLit GhcPs
mkHsFractional :: FractionalLit -> HsOverLit GhcPs
mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs
-mkHsDo :: HsStmtContext GhcRn -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs
-mkHsDoAnns :: HsStmtContext GhcRn -> LocatedL [ExprLStmt GhcPs] -> EpAnn AnnList -> HsExpr GhcPs
-mkHsComp :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
+mkHsDo :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs
+mkHsDoAnns :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> EpAnn AnnList -> HsExpr GhcPs
+mkHsComp :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
-> HsExpr GhcPs
-mkHsCompAnns :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
+mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
-> EpAnn AnnList
-> HsExpr GhcPs
@@ -575,7 +575,7 @@ nlWildPat = noLocA (WildPat noExtField )
nlWildPatName :: LPat GhcRn
nlWildPatName = noLocA (WildPat noExtField )
-nlHsDo :: HsStmtContext GhcRn -> [LStmt GhcPs (LHsExpr GhcPs)]
+nlHsDo :: HsDoFlavour -> [LStmt GhcPs (LHsExpr GhcPs)]
-> LHsExpr GhcPs
nlHsDo ctxt stmts = noLocA (mkHsDo ctxt (noLocA stmts))
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index 2b7b96f118..5cfd057299 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -904,10 +904,10 @@ dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do
out_ty = mkBigCoreVarTupTy out_ids
body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
- fail_expr <- mkFailExpr (StmtCtxt (DoExpr Nothing)) out_ty
+ fail_expr <- mkFailExpr (StmtCtxt (HsDoStmt (DoExpr Nothing))) out_ty
pat_id <- selectSimpleMatchVarL Many pat
match_code
- <- matchSimply (Var pat_id) (StmtCtxt (DoExpr Nothing)) pat body_expr fail_expr
+ <- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat body_expr fail_expr
pair_id <- newSysLocalDs Many after_c_ty
let
proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 2693bda345..1f0a0ddde5 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -778,8 +778,6 @@ dsExpr (OpApp x _ _ _) = dataConCantHappen x
dsExpr (SectionL x _ _) = dataConCantHappen x
dsExpr (SectionR x _ _) = dataConCantHappen x
dsExpr (HsBracket x _) = dataConCantHappen x
--- HsSyn constructs that just shouldn't be here:
-dsExpr (HsDo {}) = panic "dsExpr:HsDo"
ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
ds_prag_expr (HsPragSCC _ _ cc) expr = do
@@ -936,7 +934,7 @@ handled in GHC.HsToCore.ListComp). Basically does the translation given in the
Haskell 98 report:
-}
-dsDo :: HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr
+dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo ctx stmts
= goL stmts
where
@@ -961,7 +959,7 @@ dsDo ctx stmts
= do { body <- goL stmts
; rhs' <- dsLExpr rhs
; var <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat
- ; match <- matchSinglePatVar var Nothing (StmtCtxt ctx) pat
+ ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat
(xbstc_boundResultType xbs) (cantFailMatchResult body)
; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs)
; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }
@@ -982,7 +980,7 @@ dsDo ctx stmts
; let match_args (pat, fail_op) (vs,body)
= do { var <- selectSimpleMatchVarL Many pat
- ; match <- matchSinglePatVar var Nothing (StmtCtxt ctx) pat
+ ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat
body_ty (cantFailMatchResult body)
; match_code <- dsHandleMonadicFailure ctx pat match fail_op
; return (var:vs, match_code)
diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs
index 6c988ee047..3f649903a1 100644
--- a/compiler/GHC/HsToCore/ListComp.hs
+++ b/compiler/GHC/HsToCore/ListComp.hs
@@ -288,7 +288,7 @@ deBindComp pat core_list1 quals core_list2 = do
letrec_body = App (Var h) core_list1
rest_expr <- deListComp quals core_fail
- core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail
+ core_match <- matchSimply (Var u2) (StmtCtxt (HsDoStmt ListComp)) pat rest_expr core_fail
let
rhs = Lam u1 $
@@ -376,7 +376,7 @@ dfBindComp c_id n_id (pat, core_list1) quals = do
core_rest <- dfListComp c_id b quals
-- build the pattern match
- core_expr <- matchSimply (Var x) (StmtCtxt ListComp)
+ core_expr <- matchSimply (Var x) (StmtCtxt (HsDoStmt ListComp))
pat core_rest (Var b)
-- now build the outermost foldr, and return
@@ -614,9 +614,9 @@ dsMcBindStmt :: LPat GhcTc
dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
= do { body <- dsMcStmts stmts
; var <- selectSimpleMatchVarL Many pat
- ; match <- matchSinglePatVar var Nothing (StmtCtxt (DoExpr Nothing)) pat
+ ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat
res1_ty (cantFailMatchResult body)
- ; match_code <- dsHandleMonadicFailure (MonadComp :: HsStmtContext GhcRn) pat match fail_op
+ ; match_code <- dsHandleMonadicFailure MonadComp pat match fail_op
; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
-- Desugar nested monad comprehensions, for example in `then..` constructs
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index 333929c956..c1426474be 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -956,7 +956,7 @@ CPR-friendly. This matters a lot: if you don't get it right, you lose
the tail call property. For example, see #3403.
-}
-dsHandleMonadicFailure :: HsStmtContext GhcRn -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
+dsHandleMonadicFailure :: HsDoFlavour -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
-- In a do expression, pattern-match failure just calls
-- the monadic 'fail' rather than throwing an exception
dsHandleMonadicFailure ctx pat match m_fail_op =
@@ -977,9 +977,9 @@ dsHandleMonadicFailure ctx pat match m_fail_op =
fail_expr <- dsSyntaxExpr fail_op [fail_msg]
body fail_expr
-mk_fail_msg :: DynFlags -> HsStmtContext GhcRn -> LocatedA e -> String
+mk_fail_msg :: DynFlags -> HsDoFlavour -> LocatedA e -> String
mk_fail_msg dflags ctx pat
- = showPpr dflags $ text "Pattern match failure in" <+> pprStmtContext ctx
+ = showPpr dflags $ text "Pattern match failure in" <+> pprHsDoFlavour ctx
<+> text "at" <+> ppr (getLocA pat)
{- Note [Desugaring representation-polymorphic applications]
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 946b9a87f3..6b58b70558 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -1362,7 +1362,7 @@ addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do
-- If the flag MonadComprehensions is set, return a 'MonadComp' context,
-- otherwise use the usual 'ListComp' context
-checkMonadComp :: PV (HsStmtContext GhcRn)
+checkMonadComp :: PV HsDoFlavour
checkMonadComp = do
monadComprehensions <- getBit MonadComprehensionsBit
return $ if monadComprehensions
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 72e18ed388..1e1f7bdce1 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -388,11 +388,11 @@ rnExpr (HsLet _ binds expr)
; return (HsLet noExtField binds' expr', fvExpr) }
rnExpr (HsDo _ do_or_lc (L l stmts))
- = do { ((stmts', _), fvs) <-
- rnStmtsWithPostProcessing do_or_lc rnExpr
- postProcessStmtsForApplicativeDo stmts
- (\ _ -> return ((), emptyFVs))
- ; return ( HsDo noExtField do_or_lc (L l stmts'), fvs ) }
+ = do { ((stmts1, _), fvs1) <-
+ rnStmtsWithFreeVars (HsDoStmt do_or_lc) rnExpr stmts
+ (\ _ -> return ((), emptyFVs))
+ ; (pp_stmts, fvs2) <- postProcessStmtsForApplicativeDo do_or_lc stmts1
+ ; return ( HsDo noExtField do_or_lc (L l pp_stmts), fvs1 `plusFV` fvs2 ) }
-- ExplicitList: see Note [Handling overloaded and rebindable constructs]
rnExpr (ExplicitList _ exps)
@@ -984,34 +984,13 @@ rnStmts :: AnnoBody body
-- ^ if these statements scope over something, this renames it
-- and returns the result.
-> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
-rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts
-
--- | like 'rnStmts' but applies a post-processing step to the renamed Stmts
-rnStmtsWithPostProcessing
- :: AnnoBody body
- => HsStmtContext GhcRn
- -> (body GhcPs -> RnM (body GhcRn, FreeVars))
- -- ^ How to rename the body of each statement (e.g. rnLExpr)
- -> (HsStmtContext GhcRn
- -> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
- -> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars))
- -- ^ postprocess the statements
- -> [LStmt GhcPs (LocatedA (body GhcPs))]
- -- ^ Statements
- -> ([Name] -> RnM (thing, FreeVars))
- -- ^ if these statements scope over something, this renames it
- -- and returns the result.
- -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
-rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside
- = do { ((stmts', thing), fvs) <-
- rnStmtsWithFreeVars ctxt rnBody stmts thing_inside
- ; (pp_stmts, fvs') <- ppStmts ctxt stmts'
- ; return ((pp_stmts, thing), fvs `plusFV` fvs')
- }
+rnStmts ctxt rnBody stmts thing_inside
+ = do { ((stmts', thing), fvs) <- rnStmtsWithFreeVars ctxt rnBody stmts thing_inside
+ ; return ((map fst stmts', thing), fvs) }
-- | maybe rearrange statements according to the ApplicativeDo transformation
postProcessStmtsForApplicativeDo
- :: HsStmtContext GhcRn
+ :: HsDoFlavour
-> [(ExprLStmt GhcRn, FreeVars)]
-> RnM ([ExprLStmt GhcRn], FreeVars)
postProcessStmtsForApplicativeDo ctxt stmts
@@ -1028,7 +1007,7 @@ postProcessStmtsForApplicativeDo ctxt stmts
; if ado_is_on && is_do_expr && not in_th_bracket
then do { traceRn "ppsfa" (ppr stmts)
; rearrangeForApplicativeDo ctxt stmts }
- else noPostProcessStmts ctxt stmts }
+ else noPostProcessStmts (HsDoStmt ctxt) stmts }
-- | strip the FreeVars annotations from statements
noPostProcessStmts
@@ -1056,7 +1035,7 @@ rnStmtsWithFreeVars ctxt _ [] thing_inside
; (thing, fvs) <- thing_inside []
; return (([], thing), fvs) }
-rnStmtsWithFreeVars mDoExpr@MDoExpr{} rnBody stmts thing_inside -- Deal with mdo
+rnStmtsWithFreeVars mDoExpr@(HsDoStmt MDoExpr{}) rnBody stmts thing_inside -- Deal with mdo
= -- Behave like do { rec { ...all but last... }; last }
do { ((stmts1, (stmts2, thing)), fvs)
<- rnStmt mDoExpr rnBody (noLocA $ mkRecStmt noAnn (noLocA all_but_last)) $ \ _ ->
@@ -1313,18 +1292,22 @@ lookupStmtNamePoly ctxt name
-- Neither is ArrowExpr, which has its own desugarer in GHC.HsToCore.Arrows
rebindableContext :: HsStmtContext GhcRn -> Bool
rebindableContext ctxt = case ctxt of
- ListComp -> False
- ArrowExpr -> False
- PatGuard {} -> False
+ HsDoStmt flavour -> rebindableDoStmtContext flavour
+ ArrowExpr -> False
+ PatGuard {} -> False
- DoExpr m -> isNothing m
- MDoExpr m -> isNothing m
- MonadComp -> True
- GhciStmtCtxt -> True -- I suppose?
ParStmtCtxt c -> rebindableContext c -- Look inside to
TransStmtCtxt c -> rebindableContext c -- the parent context
+rebindableDoStmtContext :: HsDoFlavour -> Bool
+rebindableDoStmtContext flavour = case flavour of
+ ListComp -> False
+ DoExpr m -> isNothing m
+ MDoExpr m -> isNothing m
+ MonadComp -> True
+ GhciStmtCtxt -> True -- I suppose?
+
{-
Note [Renaming parallel Stmts]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1546,7 +1529,7 @@ segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
| null segs
= ([], fvs_later)
- | MDoExpr _ <- ctxt
+ | HsDoStmt (MDoExpr _) <- ctxt
= segsToStmts empty_rec_stmt grouped_segs fvs_later
-- Step 4: Turn the segments into Stmts
-- Use RecStmt when and only when there are fwd refs
@@ -1852,7 +1835,7 @@ instance Outputable MonadNames where
-- | rearrange a list of statements using ApplicativeDoStmt. See
-- Note [ApplicativeDo].
rearrangeForApplicativeDo
- :: HsStmtContext GhcRn
+ :: HsDoFlavour
-> [(ExprLStmt GhcRn, FreeVars)]
-> RnM ([ExprLStmt GhcRn], FreeVars)
@@ -1863,8 +1846,8 @@ rearrangeForApplicativeDo ctxt stmts0 = do
let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts
| otherwise = mkStmtTreeHeuristic stmts
traceRn "rearrangeForADo" (ppr stmt_tree)
- (return_name, _) <- lookupQualifiedDoName ctxt returnMName
- (pure_name, _) <- lookupQualifiedDoName ctxt pureAName
+ (return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName
+ (pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName
let monad_names = MonadNames { return_name = return_name
, pure_name = pure_name }
stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs
@@ -1978,7 +1961,7 @@ mkStmtTreeOptimal stmts =
-- ApplicativeStmt where necessary.
stmtTreeToStmts
:: MonadNames
- -> HsStmtContext GhcRn
+ -> HsDoFlavour
-> ExprStmtTree
-> [ExprLStmt GhcRn] -- ^ the "tail"
-> FreeVars -- ^ free variables of the tail
@@ -2062,7 +2045,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
if | L _ ApplicativeStmt{} <- last stmts' ->
return (unLoc tup, emptyNameSet)
| otherwise -> do
- (ret, _) <- lookupQualifiedDoExpr ctxt returnMName
+ (ret, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) returnMName
let expr = HsApp noComments (noLocA ret) tup
return (expr, emptyFVs)
return ( ApplicativeArgMany
@@ -2266,17 +2249,17 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
-- it this way rather than try to ignore the return later in both the
-- typechecker and the desugarer (I tried it that way first!).
mkApplicativeStmt
- :: HsStmtContext GhcRn
+ :: HsDoFlavour
-> [ApplicativeArg GhcRn] -- ^ The args
-> Bool -- ^ True <=> need a join
-> [ExprLStmt GhcRn] -- ^ The body statements
-> RnM ([ExprLStmt GhcRn], FreeVars)
mkApplicativeStmt ctxt args need_join body_stmts
- = do { (fmap_op, fvs1) <- lookupQualifiedDoStmtName ctxt fmapName
- ; (ap_op, fvs2) <- lookupQualifiedDoStmtName ctxt apAName
+ = do { (fmap_op, fvs1) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) fmapName
+ ; (ap_op, fvs2) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) apAName
; (mb_join, fvs3) <-
if need_join then
- do { (join_op, fvs) <- lookupQualifiedDoStmtName ctxt joinMName
+ do { (join_op, fvs) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) joinMName
; return (Just join_op, fvs) }
else
return (Nothing, emptyNameSet)
@@ -2350,11 +2333,11 @@ checkLastStmt :: AnnoBody body => HsStmtContext GhcRn
-> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
checkLastStmt ctxt lstmt@(L loc stmt)
= case ctxt of
- ListComp -> check_comp
- MonadComp -> check_comp
+ HsDoStmt ListComp -> check_comp
+ HsDoStmt MonadComp -> check_comp
+ HsDoStmt DoExpr{} -> check_do
+ HsDoStmt MDoExpr{} -> check_do
ArrowExpr -> check_do
- DoExpr{} -> check_do
- MDoExpr{} -> check_do
_ -> check_other
where
check_do -- Expect BodyStmt, and change it to LastStmt
@@ -2413,14 +2396,20 @@ okStmt dflags ctxt stmt
= case ctxt of
PatGuard {} -> okPatGuardStmt stmt
ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt
- DoExpr{} -> okDoStmt dflags ctxt stmt
- MDoExpr{} -> okDoStmt dflags ctxt stmt
+ HsDoStmt flavour -> okDoFlavourStmt dflags flavour ctxt stmt
ArrowExpr -> okDoStmt dflags ctxt stmt
- GhciStmtCtxt -> okDoStmt dflags ctxt stmt
- ListComp -> okCompStmt dflags ctxt stmt
- MonadComp -> okCompStmt dflags ctxt stmt
TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
+okDoFlavourStmt
+ :: DynFlags -> HsDoFlavour -> HsStmtContext GhcRn
+ -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity
+okDoFlavourStmt dflags flavour ctxt stmt = case flavour of
+ DoExpr{} -> okDoStmt dflags ctxt stmt
+ MDoExpr{} -> okDoStmt dflags ctxt stmt
+ GhciStmtCtxt -> okDoStmt dflags ctxt stmt
+ ListComp -> okCompStmt dflags ctxt stmt
+ MonadComp -> okCompStmt dflags ctxt stmt
+
-------------
okPatGuardStmt :: Stmt GhcPs (LocatedA (body GhcPs)) -> Validity
okPatGuardStmt stmt
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 0a149f473e..ab9bf28564 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -217,7 +217,7 @@ matchNameMaker ctxt = LamMk report_unused
-- Do not report unused names in interactive contexts
-- i.e. when you type 'x <- e' at the GHCi prompt
report_unused = case ctxt of
- StmtCtxt GhciStmtCtxt -> False
+ StmtCtxt (HsDoStmt GhciStmtCtxt) -> False
-- also, don't warn in pattern quotes, as there
-- is no RHS where the variables can be used!
ThPatQuote -> False
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index 06118359f1..9b8b68aad6 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -299,7 +299,7 @@ tcGRHS ctxt res_ty (GRHS _ guards rhs)
************************************************************************
-}
-tcDoStmts :: HsStmtContext GhcRn
+tcDoStmts :: HsDoFlavour
-> LocatedL [LStmt GhcRn (LHsExpr GhcRn)]
-> ExpRhoType
-> TcM (HsExpr GhcTc) -- Returns a HsDo
@@ -307,26 +307,25 @@ tcDoStmts ListComp (L l stmts) res_ty
= do { res_ty <- expTypeToType res_ty
; (co, elt_ty) <- matchExpectedListTy res_ty
; let list_ty = mkListTy elt_ty
- ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts
+ ; stmts' <- tcStmts (HsDoStmt ListComp) (tcLcStmt listTyCon) stmts
(mkCheckExpType elt_ty)
; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty
- = do { stmts' <- tcStmts doExpr tcDoStmt stmts res_ty
+ = do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
; res_ty <- readExpType res_ty
; return (HsDo res_ty doExpr (L l stmts')) }
tcDoStmts mDoExpr@(MDoExpr _) (L l stmts) res_ty
- = do { stmts' <- tcStmts mDoExpr tcDoStmt stmts res_ty
+ = do { stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty
; res_ty <- readExpType res_ty
; return (HsDo res_ty mDoExpr (L l stmts')) }
tcDoStmts MonadComp (L l stmts) res_ty
- = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
+ = do { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty
; res_ty <- readExpType res_ty
; return (HsDo res_ty MonadComp (L l stmts')) }
-
-tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
+tcDoStmts ctxt@GhciStmtCtxt _ _ = pprPanic "tcDoStmts" (pprHsDoFlavour ctxt)
tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody body res_ty
@@ -1068,10 +1067,10 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
goArg _body_ty (ApplicativeArgMany x stmts ret pat ctxt, pat_ty, exp_ty)
= do { (stmts', (ret',pat')) <-
- tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $
+ tcStmtsAndThen (HsDoStmt ctxt) tcDoStmt stmts (mkCheckExpType exp_ty) $
\res_ty -> do
{ ret' <- tcExpr ret res_ty
- ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $
+ ; (pat', _) <- tcCheckPat (StmtCtxt (HsDoStmt ctxt)) pat (unrestricted pat_ty) $
return ()
; return (ret', pat')
}
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index f458605c14..5be998e07a 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -2391,7 +2391,7 @@ But for naked expressions, you will have
tcUserStmt rdr_stmt@(L loc _)
= do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $
- rnStmts GhciStmtCtxt rnExpr [rdr_stmt] $ \_ -> do
+ rnStmts (HsDoStmt GhciStmtCtxt) rnExpr [rdr_stmt] $ \_ -> do
fix_env <- getFixityEnv
return (fix_env, emptyFVs)
-- Don't try to typecheck if the renamer fails!
@@ -2456,7 +2456,7 @@ tcGhciStmts stmts
; ret_id <- tcLookupId returnIOName -- return @ IO
; let ret_ty = mkListTy unitTy
io_ret_ty = mkTyConApp ioTyCon [ret_ty]
- tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts
+ tc_io_stmts = tcStmtsAndThen (HsDoStmt GhciStmtCtxt) tcDoStmt stmts
(mkCheckExpType io_ret_ty)
names = collectLStmtsBinders CollNoDictBinders stmts
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index de2602e6c5..0f9bb35cd6 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1177,7 +1177,7 @@ cvtOpApp x op y
-- Do notation and statements
-------------------------------------
-cvtHsDo :: HsStmtContext GhcRn -> [TH.Stmt] -> CvtM (HsExpr GhcPs)
+cvtHsDo :: HsDoFlavour -> [TH.Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo do_or_lc stmts
| null stmts = failWith (text "Empty stmt list in do-block")
| otherwise
@@ -1191,7 +1191,7 @@ cvtHsDo do_or_lc stmts
; return $ HsDo noAnn do_or_lc (noLocA (stmts'' ++ [last''])) }
where
- bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon
+ bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAHsDoFlavour do_or_lc <> colon
, nest 2 $ Outputable.ppr stmt
, text "(It should be an expression.)" ]
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 88f15515c8..34058b58f5 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -488,10 +488,7 @@ data HsExpr p
-- For details on above see note [exact print annotations] in GHC.Parser.Annotation
| HsDo (XDo p) -- Type of the whole expression
- (HsStmtContext (HsDoRn p))
- -- The parameterisation of the above is unimportant
- -- because in this context we never use
- -- the PatGuard or ParStmt variant
+ HsDoFlavour
(XRec p [ExprLStmt p]) -- "do":one or more stmts
-- | Syntactic list: [a,b,c,...]
@@ -665,7 +662,6 @@ data HsExpr p
-- | The AST used to hard-refer to GhcPass, which was a layer violation. For now,
-- we paper it over with this new extension point.
-type family HsDoRn p
type family HsBracketRn p
type family PendingRnSplice' p
type family PendingTcSplice' p
@@ -1371,13 +1367,11 @@ data ApplicativeArg idL
, app_stmts :: [ExprLStmt idL] -- stmts
, final_expr :: HsExpr idL -- return (v1,..,vn), or just (v1,..,vn)
, bv_pattern :: LPat idL -- (v1,...,vn)
- , stmt_context :: HsStmtContext (ApplicativeArgStmCtxPass idL)
+ , stmt_context :: HsDoFlavour
-- ^ context of the do expression, used in pprArg
}
| XApplicativeArg !(XXApplicativeArg idL)
-type family ApplicativeArgStmCtxPass idL
-
{-
Note [The type of bind in Stmts]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1720,45 +1714,68 @@ isPatSynCtxt ctxt =
-- | Haskell Statement Context.
data HsStmtContext p
- = ListComp
- | MonadComp
-
- | DoExpr (Maybe ModuleName) -- ^[ModuleName.]do { ... }
- | MDoExpr (Maybe ModuleName) -- ^[ModuleName.]mdo { ... } ie recursive do-expression
- | ArrowExpr -- ^do-notation in an arrow-command context
-
- | GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs
+ = HsDoStmt HsDoFlavour -- ^Context for HsDo (do-notation and comprehensions)
| PatGuard (HsMatchContext p) -- ^Pattern guard for specified thing
| ParStmtCtxt (HsStmtContext p) -- ^A branch of a parallel stmt
| TransStmtCtxt (HsStmtContext p) -- ^A branch of a transform stmt
+ | ArrowExpr -- ^do-notation in an arrow-command context
+
+data HsDoFlavour
+ = DoExpr (Maybe ModuleName) -- ^[ModuleName.]do { ... }
+ | MDoExpr (Maybe ModuleName) -- ^[ModuleName.]mdo { ... } ie recursive do-expression
+ | GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs
+ | ListComp
+ | MonadComp
qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName
qualifiedDoModuleName_maybe ctxt = case ctxt of
- DoExpr m -> m
- MDoExpr m -> m
+ HsDoStmt (DoExpr m) -> m
+ HsDoStmt (MDoExpr m) -> m
_ -> Nothing
isComprehensionContext :: HsStmtContext id -> Bool
-- Uses comprehension syntax [ e | quals ]
-isComprehensionContext ListComp = True
-isComprehensionContext MonadComp = True
isComprehensionContext (ParStmtCtxt c) = isComprehensionContext c
isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c
-isComprehensionContext _ = False
+isComprehensionContext ArrowExpr = False
+isComprehensionContext (PatGuard _) = False
+isComprehensionContext (HsDoStmt flavour) = isDoComprehensionContext flavour
+
+isDoComprehensionContext :: HsDoFlavour -> Bool
+isDoComprehensionContext GhciStmtCtxt = False
+isDoComprehensionContext (DoExpr _) = False
+isDoComprehensionContext (MDoExpr _) = False
+isDoComprehensionContext ListComp = True
+isDoComprehensionContext MonadComp = True
-- | Is this a monadic context?
isMonadStmtContext :: HsStmtContext id -> Bool
-isMonadStmtContext MonadComp = True
-isMonadStmtContext DoExpr{} = True
-isMonadStmtContext MDoExpr{} = True
-isMonadStmtContext GhciStmtCtxt = True
isMonadStmtContext (ParStmtCtxt ctxt) = isMonadStmtContext ctxt
isMonadStmtContext (TransStmtCtxt ctxt) = isMonadStmtContext ctxt
-isMonadStmtContext _ = False -- ListComp, PatGuard, ArrowExpr
+isMonadStmtContext (HsDoStmt flavour) = isMonadDoStmtContext flavour
+isMonadStmtContext (PatGuard _) = False
+isMonadStmtContext ArrowExpr = False
+
+isMonadDoStmtContext :: HsDoFlavour -> Bool
+isMonadDoStmtContext ListComp = False
+isMonadDoStmtContext MonadComp = True
+isMonadDoStmtContext DoExpr{} = True
+isMonadDoStmtContext MDoExpr{} = True
+isMonadDoStmtContext GhciStmtCtxt = True
isMonadCompContext :: HsStmtContext id -> Bool
-isMonadCompContext MonadComp = True
-isMonadCompContext _ = False
+isMonadCompContext (HsDoStmt flavour) = isMonadDoCompContext flavour
+isMonadCompContext (ParStmtCtxt _) = False
+isMonadCompContext (TransStmtCtxt _) = False
+isMonadCompContext (PatGuard _) = False
+isMonadCompContext ArrowExpr = False
+
+isMonadDoCompContext :: HsDoFlavour -> Bool
+isMonadDoCompContext MonadComp = True
+isMonadDoCompContext ListComp = False
+isMonadDoCompContext GhciStmtCtxt = False
+isMonadDoCompContext (DoExpr _) = False
+isMonadDoCompContext (MDoExpr _) = False
matchSeparator :: HsMatchContext p -> SDoc
matchSeparator (FunRhs {}) = text "="
@@ -1806,24 +1823,13 @@ pprMatchContextNoun PatSyn = text "pattern synonym declaration"
-----------------
pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p)
=> HsStmtContext p -> SDoc
-pprAStmtContext ctxt = article <+> pprStmtContext ctxt
- where
- pp_an = text "an"
- pp_a = text "a"
- article = case ctxt of
- MDoExpr Nothing -> pp_an
- GhciStmtCtxt -> pp_an
- _ -> pp_a
-
+pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour
+pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt
-----------------
-pprStmtContext GhciStmtCtxt = text "interactive GHCi command"
-pprStmtContext (DoExpr m) = prependQualified m (text "'do' block")
-pprStmtContext (MDoExpr m) = prependQualified m (text "'mdo' block")
-pprStmtContext ArrowExpr = text "'do' block in an arrow command"
-pprStmtContext ListComp = text "list comprehension"
-pprStmtContext MonadComp = text "monad comprehension"
+pprStmtContext (HsDoStmt flavour) = pprHsDoFlavour flavour
pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt
+pprStmtContext ArrowExpr = text "'do' block in an arrow command"
-- Drop the inner contexts when reporting errors, else we get
-- Unexpected transform statement
@@ -1837,6 +1843,21 @@ pprStmtContext (TransStmtCtxt c) =
ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])
(pprStmtContext c)
+pprAHsDoFlavour, pprHsDoFlavour :: HsDoFlavour -> SDoc
+pprAHsDoFlavour flavour = article <+> pprHsDoFlavour flavour
+ where
+ pp_an = text "an"
+ pp_a = text "a"
+ article = case flavour of
+ MDoExpr Nothing -> pp_an
+ GhciStmtCtxt -> pp_an
+ _ -> pp_a
+pprHsDoFlavour (DoExpr m) = prependQualified m (text "'do' block")
+pprHsDoFlavour (MDoExpr m) = prependQualified m (text "'mdo' block")
+pprHsDoFlavour ListComp = text "list comprehension"
+pprHsDoFlavour MonadComp = text "monad comprehension"
+pprHsDoFlavour GhciStmtCtxt = text "interactive GHCi command"
+
prependQualified :: Maybe ModuleName -> SDoc -> SDoc
prependQualified Nothing t = t
prependQualified (Just _) t = text "qualified" <+> t
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index e4f689bbbb..74135cb9f6 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -2080,14 +2080,12 @@ instance ExactPrint (HsExpr GhcPs) where
-- ---------------------------------------------------------------------
exactDo :: (ExactPrint body)
- => EpAnn AnnList -> (HsStmtContext any) -> body -> EPP ()
+ => EpAnn AnnList -> HsDoFlavour -> body -> EPP ()
exactDo an (DoExpr m) stmts = exactMdo an m AnnDo >> markAnnotatedWithLayout stmts
exactDo an GhciStmtCtxt stmts = markLocatedAAL an al_rest AnnDo >> markAnnotatedWithLayout stmts
-exactDo an ArrowExpr stmts = markLocatedAAL an al_rest AnnDo >> markAnnotatedWithLayout stmts
exactDo an (MDoExpr m) stmts = exactMdo an m AnnMdo >> markAnnotatedWithLayout stmts
exactDo _ ListComp stmts = markAnnotatedWithLayout stmts
exactDo _ MonadComp stmts = markAnnotatedWithLayout stmts
-exactDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt
exactMdo :: EpAnn AnnList -> Maybe ModuleName -> AnnKeywordId -> EPP ()
exactMdo an Nothing kw = markLocatedAAL an al_rest kw
diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs
index 5739df9dd3..74a861e773 100644
--- a/utils/check-exact/Utils.hs
+++ b/utils/check-exact/Utils.hs
@@ -207,19 +207,8 @@ orderByKey keys order
-- ---------------------------------------------------------------------
-isListComp :: HsStmtContext name -> Bool
-isListComp cts = case cts of
- ListComp -> True
- MonadComp -> True
-
- DoExpr {} -> False
- MDoExpr {} -> False
- ArrowExpr -> False
- GhciStmtCtxt -> False
-
- PatGuard {} -> False
- ParStmtCtxt {} -> False
- TransStmtCtxt {} -> False
+isListComp :: HsDoFlavour -> Bool
+isListComp = isDoComprehensionContext
-- ---------------------------------------------------------------------
View Lorry Controller Status