summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/Builtin/Names/TH.hs17
-rw-r--r--compiler/GHC/Driver/Session.hs1
-rw-r--r--compiler/GHC/Hs/Expr.hs67
-rw-r--r--compiler/GHC/Hs/Instances.hs8
-rw-r--r--compiler/GHC/HsToCore/Arrows.hs4
-rw-r--r--compiler/GHC/HsToCore/Coverage.hs3
-rw-r--r--compiler/GHC/HsToCore/Expr.hs22
-rw-r--r--compiler/GHC/HsToCore/ListComp.hs2
-rw-r--r--compiler/GHC/HsToCore/Quote.hs34
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs2
-rw-r--r--compiler/GHC/Parser.y85
-rw-r--r--compiler/GHC/Parser/Lexer.x65
-rw-r--r--compiler/GHC/Parser/PostProcess.hs50
-rw-r--r--compiler/GHC/Rename/Env.hs47
-rw-r--r--compiler/GHC/Rename/Expr.hs134
-rw-r--r--compiler/GHC/Tc/Deriv/Generate.hs4
-rw-r--r--compiler/GHC/Tc/Gen/Match.hs16
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs10
-rw-r--r--compiler/GHC/ThToHs.hs4
19 files changed, 383 insertions, 192 deletions
diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs
index dcee4259f0..1e2e2f97a7 100644
--- a/compiler/GHC/Builtin/Names/TH.hs
+++ b/compiler/GHC/Builtin/Names/TH.hs
@@ -30,6 +30,7 @@ templateHaskellNames = [
returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
mkNameSName,
+ mkModNameName,
liftStringName,
unTypeName,
unTypeQName,
@@ -160,6 +161,7 @@ templateHaskellNames = [
ruleBndrTyConName, tySynEqnTyConName,
roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName,
overlapTyConName, derivClauseTyConName, derivStrategyTyConName,
+ modNameTyConName,
-- Quasiquoting
quoteDecName, quoteTypeName, quoteExpName, quotePatName]
@@ -191,7 +193,8 @@ quoteClassName = thCls (fsLit "Quote") quoteClassKey
qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
matchTyConName, clauseTyConName, funDepTyConName, predTyConName,
- tExpTyConName, injAnnTyConName, overlapTyConName, decsTyConName :: Name
+ tExpTyConName, injAnnTyConName, overlapTyConName, decsTyConName,
+ modNameTyConName :: Name
qTyConName = thTc (fsLit "Q") qTyConKey
nameTyConName = thTc (fsLit "Name") nameTyConKey
fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
@@ -208,11 +211,12 @@ predTyConName = thTc (fsLit "Pred") predTyConKey
tExpTyConName = thTc (fsLit "TExp") tExpTyConKey
injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey
overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey
+modNameTyConName = thTc (fsLit "ModName") modNameTyConKey
returnQName, bindQName, sequenceQName, newNameName, liftName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName,
- unsafeTExpCoerceName, liftTypedName :: Name
+ unsafeTExpCoerceName, liftTypedName, mkModNameName :: Name
returnQName = thFun (fsLit "returnQ") returnQIdKey
bindQName = thFun (fsLit "bindQ") bindQIdKey
sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
@@ -225,6 +229,7 @@ mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey
+mkModNameName = thFun (fsLit "mkModName") mkModNameIdKey
unTypeName = thFun (fsLit "unType") unTypeIdKey
unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey
unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey
@@ -649,8 +654,8 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
funDepTyConKey, predTyConKey,
predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey,
roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey,
- overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey
- :: Unique
+ overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey,
+ modNameTyConKey :: Unique
expTyConKey = mkPreludeTyConUnique 200
matchTyConKey = mkPreludeTyConUnique 201
clauseTyConKey = mkPreludeTyConUnique 202
@@ -684,6 +689,7 @@ overlapTyConKey = mkPreludeTyConUnique 233
derivClauseTyConKey = mkPreludeTyConUnique 234
derivStrategyTyConKey = mkPreludeTyConUnique 235
decsTyConKey = mkPreludeTyConUnique 236
+modNameTyConKey = mkPreludeTyConUnique 238
{- *********************************************************************
* *
@@ -737,7 +743,7 @@ incoherentDataConKey = mkPreludeDataConUnique 212
returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey,
- unsafeTExpCoerceIdKey, liftTypedIdKey :: Unique
+ unsafeTExpCoerceIdKey, liftTypedIdKey, mkModNameIdKey :: Unique
returnQIdKey = mkPreludeMiscIdUnique 200
bindQIdKey = mkPreludeMiscIdUnique 201
sequenceQIdKey = mkPreludeMiscIdUnique 202
@@ -753,6 +759,7 @@ unTypeIdKey = mkPreludeMiscIdUnique 211
unTypeQIdKey = mkPreludeMiscIdUnique 212
unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213
liftTypedIdKey = mkPreludeMiscIdUnique 214
+mkModNameIdKey = mkPreludeMiscIdUnique 215
-- data Lit = ...
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 52ad38dfa2..2ffcf250b7 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3836,6 +3836,7 @@ xFlagsDeps = [
flagSpec "QuantifiedConstraints" LangExt.QuantifiedConstraints,
flagSpec "PostfixOperators" LangExt.PostfixOperators,
flagSpec "QuasiQuotes" LangExt.QuasiQuotes,
+ flagSpec "QualifiedDo" LangExt.QualifiedDo,
flagSpec "Rank2Types" LangExt.RankNTypes,
flagSpec "RankNTypes" LangExt.RankNTypes,
flagSpec "RebindableSyntax" LangExt.RebindableSyntax,
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 20aeb72872..ffe23e5588 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -45,6 +45,7 @@ import GHC.Types.Name.Set
import GHC.Types.Basic
import GHC.Core.ConLike
import GHC.Types.SrcLoc
+import GHC.Unit.Module (ModuleName)
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Data.FastString
@@ -2068,6 +2069,8 @@ 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 GhcRn -- context of the do expression
+ -- used in pprArg
}
| XApplicativeArg !(XXApplicativeArg idL)
@@ -2306,7 +2309,7 @@ pprStmt (ApplicativeStmt _ args mb_join)
:: ExprStmt (GhcPass idL))]
| otherwise =
[ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))]
- flattenArg (_, ApplicativeArgMany _ stmts _ _) =
+ flattenArg (_, ApplicativeArgMany _ stmts _ _ _) =
concatMap flattenStmt stmts
pp_debug =
@@ -2331,10 +2334,10 @@ pprArg (ApplicativeArgOne _ pat expr isBody)
:: ExprStmt (GhcPass idL))
| otherwise =
ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))
-pprArg (ApplicativeArgMany _ stmts return pat) =
+pprArg (ApplicativeArgMany _ stmts return pat ctxt) =
ppr pat <+>
text "<-" <+>
- ppr (HsDo (panic "pprStmt") DoExpr (noLoc
+ ppr (HsDo (panic "pprStmt") ctxt (noLoc
(stmts ++
[noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)])))
@@ -2358,14 +2361,21 @@ pprBy (Just e) = text "by" <+> ppr e
pprDo :: (OutputableBndrId p, Outputable body)
=> HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc
-pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts
+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 stmts = text "mdo" <+> 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
+ppr_module_name_prefix :: Maybe ModuleName -> SDoc
+ppr_module_name_prefix = \case
+ Nothing -> empty
+ Just module_name -> ppr module_name <> char '.'
+
ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR,
Outputable body)
=> [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc
@@ -2756,8 +2766,6 @@ data HsMatchContext p
| ThPatSplice -- ^A Template Haskell pattern splice
| ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |]
| PatSyn -- ^A pattern synonym declaration
-deriving instance Data (HsMatchContext GhcPs)
-deriving instance Data (HsMatchContext GhcRn)
instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where
ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)
@@ -2784,16 +2792,20 @@ data HsStmtContext p
= ListComp
| MonadComp
- | DoExpr -- ^do { ... }
- | MDoExpr -- ^mdo { ... } ie recursive do-expression
+ | 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
| 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
-deriving instance Data (HsStmtContext GhcPs)
-deriving instance Data (HsStmtContext GhcRn)
+
+qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName
+qualifiedDoModuleName_maybe ctxt = case ctxt of
+ DoExpr m -> m
+ MDoExpr m -> m
+ _ -> Nothing
isComprehensionContext :: HsStmtContext id -> Bool
-- Uses comprehension syntax [ e | quals ]
@@ -2803,16 +2815,15 @@ isComprehensionContext (ParStmtCtxt c) = isComprehensionContext c
isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c
isComprehensionContext _ = False
--- | Should pattern match failure in a 'HsStmtContext' be desugared using
--- 'MonadFail'?
-isMonadFailStmtContext :: HsStmtContext id -> Bool
-isMonadFailStmtContext MonadComp = True
-isMonadFailStmtContext DoExpr = True
-isMonadFailStmtContext MDoExpr = True
-isMonadFailStmtContext GhciStmtCtxt = True
-isMonadFailStmtContext (ParStmtCtxt ctxt) = isMonadFailStmtContext ctxt
-isMonadFailStmtContext (TransStmtCtxt ctxt) = isMonadFailStmtContext ctxt
-isMonadFailStmtContext _ = False -- ListComp, PatGuard, ArrowExpr
+-- | 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
isMonadCompContext :: HsStmtContext id -> Bool
isMonadCompContext MonadComp = True
@@ -2869,15 +2880,15 @@ pprAStmtContext ctxt = article <+> pprStmtContext ctxt
pp_an = text "an"
pp_a = text "a"
article = case ctxt of
- MDoExpr -> pp_an
+ MDoExpr Nothing -> pp_an
GhciStmtCtxt -> pp_an
_ -> pp_a
-----------------
pprStmtContext GhciStmtCtxt = text "interactive GHCi command"
-pprStmtContext DoExpr = text "'do' block"
-pprStmtContext MDoExpr = text "'mdo' block"
+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"
@@ -2895,6 +2906,10 @@ pprStmtContext (TransStmtCtxt c) =
ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])
(pprStmtContext c)
+prependQualified :: Maybe ModuleName -> SDoc -> SDoc
+prependQualified Nothing t = t
+prependQualified (Just _) t = text "qualified" <+> t
+
instance OutputableBndrId p
=> Outputable (HsStmtContext (GhcPass p)) where
ppr = pprStmtContext
@@ -2917,9 +2932,9 @@ matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (Stmt
matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard"
matchContextErrString (StmtCtxt GhciStmtCtxt) = text "interactive GHCi command"
-matchContextErrString (StmtCtxt DoExpr) = text "'do' block"
+matchContextErrString (StmtCtxt (DoExpr m)) = prependQualified m (text "'do' block")
matchContextErrString (StmtCtxt ArrowExpr) = text "'do' block"
-matchContextErrString (StmtCtxt MDoExpr) = text "'mdo' block"
+matchContextErrString (StmtCtxt (MDoExpr m)) = prependQualified m (text "'mdo' block")
matchContextErrString (StmtCtxt ListComp) = text "list comprehension"
matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension"
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index c66488e770..87ded0d22d 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -315,6 +315,14 @@ deriving instance Data (ApplicativeArg GhcPs)
deriving instance Data (ApplicativeArg GhcRn)
deriving instance Data (ApplicativeArg GhcTc)
+deriving instance Data (HsStmtContext GhcPs)
+deriving instance Data (HsStmtContext GhcRn)
+deriving instance Data (HsStmtContext GhcTc)
+
+deriving instance Data (HsMatchContext GhcPs)
+deriving instance Data (HsMatchContext GhcRn)
+deriving instance Data (HsMatchContext GhcTc)
+
-- deriving instance (DataIdLR p p) => Data (HsSplice p)
deriving instance Data (HsSplice GhcPs)
deriving instance Data (HsSplice GhcRn)
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index a6c553ec1b..4f9871d412 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -912,10 +912,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) out_ty
+ fail_expr <- mkFailExpr (StmtCtxt (DoExpr Nothing)) out_ty
pat_id <- selectSimpleMatchVarL Many pat
match_code
- <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
+ <- matchSimply (Var pat_id) (StmtCtxt (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/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index e84104a68d..17335eb6b3 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -773,11 +773,12 @@ addTickApplicativeArg isGuard (op, arg) =
<*> addTickLPat pat
<*> addTickLHsExpr expr
<*> pure isBody
- addTickArg (ApplicativeArgMany x stmts ret pat) =
+ addTickArg (ApplicativeArgMany x stmts ret pat ctxt) =
(ApplicativeArgMany x)
<$> addTickLStmts isGuard stmts
<*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))
<*> addTickLPat pat
+ <*> pure ctxt
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
-> TM (ParStmtBlock GhcTc GhcTc)
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 6b55926af3..f757ba6f2b 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -474,9 +474,9 @@ dsExpr (HsLet _ binds body) = do
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
-dsExpr (HsDo _ DoExpr (L _ stmts)) = dsDo stmts
-dsExpr (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts
-dsExpr (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts
+dsExpr (HsDo _ ctx@DoExpr{} (L _ stmts)) = dsDo ctx stmts
+dsExpr (HsDo _ ctx@GhciStmtCtxt (L _ stmts)) = dsDo ctx stmts
+dsExpr (HsDo _ ctx@MDoExpr{} (L _ stmts)) = dsDo ctx stmts
dsExpr (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts
dsExpr (HsIf _ fun guard_expr then_expr else_expr)
@@ -970,8 +970,8 @@ handled in GHC.HsToCore.ListComp). Basically does the translation given in the
Haskell 98 report:
-}
-dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr
-dsDo stmts
+dsDo :: HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr
+dsDo ctx stmts
= goL stmts
where
goL [] = panic "dsDo"
@@ -995,7 +995,7 @@ dsDo stmts
= do { body <- goL stmts
; rhs' <- dsLExpr rhs
; var <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat
- ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
+ ; match <- matchSinglePatVar var (StmtCtxt ctx) pat
(xbstc_boundResultType xbs) (cantFailMatchResult body)
; match_code <- dsHandleMonadicFailure pat match (xbstc_failOp xbs)
; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }
@@ -1007,16 +1007,16 @@ dsDo stmts
do_arg (ApplicativeArgOne fail_op pat expr _) =
((pat, fail_op), dsLExpr expr)
- do_arg (ApplicativeArgMany _ stmts ret pat) =
- ((pat, Nothing), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
+ do_arg (ApplicativeArgMany _ stmts ret pat _) =
+ ((pat, Nothing), dsDo ctx (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
; rhss' <- sequence rhss
- ; body' <- dsLExpr $ noLoc $ HsDo body_ty DoExpr (noLoc stmts)
+ ; body' <- dsLExpr $ noLoc $ HsDo body_ty ctx (noLoc stmts)
; let match_args (pat, fail_op) (vs,body)
= do { var <- selectSimpleMatchVarL Many pat
- ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
+ ; match <- matchSinglePatVar var (StmtCtxt ctx) pat
body_ty (cantFailMatchResult body)
; match_code <- dsHandleMonadicFailure pat match fail_op
; return (var:vs, match_code)
@@ -1063,7 +1063,7 @@ dsDo stmts
, mg_origin = Generated })
mfix_pat = noLoc $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats
body = noLoc $ HsDo body_ty
- DoExpr (noLoc (rec_stmts ++ [ret_stmt]))
+ ctx (noLoc (rec_stmts ++ [ret_stmt]))
ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
ret_stmt = noLoc $ mkLastStmt ret_app
-- This LastStmt will be desugared with dsDo,
diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs
index 62608db9b5..edf72f2a84 100644
--- a/compiler/GHC/HsToCore/ListComp.hs
+++ b/compiler/GHC/HsToCore/ListComp.hs
@@ -616,7 +616,7 @@ dsMcBindStmt :: LPat GhcTc
dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
= do { body <- dsMcStmts stmts
; var <- selectSimpleMatchVarL Many pat
- ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
+ ; match <- matchSinglePatVar var (StmtCtxt (DoExpr Nothing)) pat
res1_ty (cantFailMatchResult body)
; match_code <- dsHandleMonadicFailure pat match fail_op
; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 056931e86c..de6e0dc383 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -41,6 +41,7 @@ import GHC.HsToCore.Match.Literal
import GHC.HsToCore.Monad
import qualified Language.Haskell.TH as TH
+import qualified Language.Haskell.TH.Syntax as TH
import GHC.Hs
import GHC.Builtin.Names
@@ -1479,9 +1480,10 @@ repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs
-- FIXME: I haven't got the types here right yet
repE e@(HsDo _ ctxt (L _ sts))
- | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
+ | Just maybeModuleName <- case ctxt of
+ { DoExpr m -> Just m; GhciStmtCtxt -> Just Nothing; _ -> Nothing }
= do { (ss,zs) <- repLSts sts;
- e' <- repDoE (nonEmptyCoreList zs);
+ e' <- repDoE maybeModuleName (nonEmptyCoreList zs);
wrapGenSyms ss e' }
| ListComp <- ctxt
@@ -1489,9 +1491,9 @@ repE e@(HsDo _ ctxt (L _ sts))
e' <- repComp (nonEmptyCoreList zs);
wrapGenSyms ss e' }
- | MDoExpr <- ctxt
+ | MDoExpr maybeModuleName <- ctxt
= do { (ss,zs) <- repLSts sts;
- e' <- repMDoE (nonEmptyCoreList zs);
+ e' <- repMDoE maybeModuleName (nonEmptyCoreList zs);
wrapGenSyms ss e' }
| otherwise
@@ -1640,7 +1642,8 @@ repUpdFields = repListM fieldExpTyConName rep_fld
--
-- do { x'1 <- gensym "x"
-- ; x'2 <- gensym "x"
--- ; doE [ BindSt (pvar x'1) [| f 1 |]
+-- ; doE Nothing
+-- [ BindSt (pvar x'1) [| f 1 |]
-- , BindSt (pvar x'2) [| f x |]
-- , NoBindSt [| g x |]
-- ]
@@ -2278,11 +2281,24 @@ repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
repCaseE :: Core (M TH.Exp) -> Core [(M TH.Match)] -> MetaM (Core (M TH.Exp))
repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
-repDoE :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
-repDoE (MkC ss) = rep2 doEName [ss]
+repDoE :: Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
+repDoE = repDoBlock doEName
-repMDoE :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
-repMDoE (MkC ss) = rep2 mdoEName [ss]
+repMDoE :: Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
+repMDoE = repDoBlock mdoEName
+
+repDoBlock :: Name -> Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
+repDoBlock doName maybeModName (MkC ss) = do
+ MkC coreModName <- coreModNameM
+ rep2 doName [coreModName, ss]
+ where
+ coreModNameM :: MetaM (Core (Maybe TH.ModName))
+ coreModNameM = case maybeModName of
+ Just m -> do
+ MkC s <- coreStringLit (moduleNameString m)
+ mName <- rep2_nw mkModNameName [s]
+ coreJust modNameTyConName mName
+ _ -> coreNothing modNameTyConName
repComp :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
repComp (MkC ss) = rep2 compEName [ss]
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 968acbb3c2..7c9c37efe2 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1310,7 +1310,7 @@ instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
[ toHie $ PS Nothing sc NoScope pat
, toHie expr
]
- toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM
+ toHie (RS sc (ApplicativeArgMany _ stmts _ pat _)) = concatM
[ toHie $ listScopes NoScope stmts
, toHie $ PS Nothing sc NoScope pat
]
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 3fddd993fe..618fc2d393 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -95,7 +95,7 @@ import GHC.Builtin.Types ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nil
%expect 232 -- shift/reduce conflicts
-{- Last updated: 04 June 2018
+{- Last updated: 08 June 2020
If you modify this parser and add a conflict, please update this comment.
You can learn more about the conflicts by passing 'happy' the -i flag:
@@ -136,7 +136,7 @@ state 60 contains 1 shift/reduce conflict.
-------------------------------------------------------------------------------
-state 61 contains 47 shift/reduce conflicts.
+state 61 contains 46 shift/reduce conflicts.
*** btype -> tyapps .
tyapps -> tyapps . tyapp
@@ -154,7 +154,7 @@ Shift parses as (per longest-parse rule):
-------------------------------------------------------------------------------
-state 143 contains 15 shift/reduce conflicts.
+state 143 contains 14 shift/reduce conflicts.
exp -> infixexp . '::' sigtype
exp -> infixexp . '-<' exp
@@ -179,7 +179,7 @@ Shift parses as (per longest-parse rule):
-------------------------------------------------------------------------------
-state 148 contains 67 shift/reduce conflicts.
+state 146 contains 66 shift/reduce conflicts.
*** exp10 -> fexp .
fexp -> fexp . aexp
@@ -197,7 +197,7 @@ Shift parses as (per longest-parse rule):
-------------------------------------------------------------------------------
-state 203 contains 27 shift/reduce conflicts.
+state 200 contains 27 shift/reduce conflicts.
aexp2 -> TH_TY_QUOTE . tyvar
aexp2 -> TH_TY_QUOTE . gtycon
@@ -216,7 +216,7 @@ Shift parses as (per longest-parse rule):
-------------------------------------------------------------------------------
-state 299 contains 1 shift/reduce conflicts.
+state 294 contains 1 shift/reduce conflicts.
rule -> STRING . rule_activation rule_forall infixexp '=' exp
@@ -234,7 +234,7 @@ a rule instructing how to rewrite the expression '[0] f'.
-------------------------------------------------------------------------------
-state 309 contains 1 shift/reduce conflict.
+state 305 contains 1 shift/reduce conflict.
*** type -> btype .
type -> btype . '->' ctype
@@ -245,7 +245,7 @@ Same as state 61 but without contexts.
-------------------------------------------------------------------------------
-state 353 contains 1 shift/reduce conflicts.
+state 349 contains 1 shift/reduce conflicts.
tup_exprs -> commas . tup_tail
sysdcon_nolist -> '(' commas . ')'
@@ -262,7 +262,7 @@ See also Note [ExplicitTuple] in GHC.Hs.Expr.
-------------------------------------------------------------------------------
-state 408 contains 1 shift/reduce conflicts.
+state 407 contains 1 shift/reduce conflicts.
tup_exprs -> commas . tup_tail
sysdcon_nolist -> '(#' commas . '#)'
@@ -274,17 +274,17 @@ Same as State 354 for unboxed tuples.
-------------------------------------------------------------------------------
-state 416 contains 67 shift/reduce conflicts.
+state 416 contains 66 shift/reduce conflicts.
*** exp10 -> '-' fexp .
fexp -> fexp . aexp
fexp -> fexp . TYPEAPP atype
-Same as 149 but with a unary minus.
+Same as 146 but with a unary minus.
-------------------------------------------------------------------------------
-state 481 contains 1 shift/reduce conflict.
+state 472 contains 1 shift/reduce conflict.
oqtycon -> '(' qtyconsym . ')'
*** qtyconop -> qtyconsym .
@@ -298,7 +298,7 @@ parenthesized infix type expression of length 1.
-------------------------------------------------------------------------------
-state 678 contains 1 shift/reduce conflicts.
+state 665 contains 1 shift/reduce conflicts.
*** aexp2 -> ipvar .
dbind -> ipvar . '=' exp
@@ -313,7 +313,7 @@ sensible meaning, namely the lhs of an implicit binding.
-------------------------------------------------------------------------------
-state 756 contains 1 shift/reduce conflicts.
+state 750 contains 1 shift/reduce conflicts.
rule -> STRING rule_activation . rule_forall infixexp '=' exp
@@ -330,7 +330,7 @@ doesn't include 'forall'.
-------------------------------------------------------------------------------
-state 992 contains 1 shift/reduce conflicts.
+state 986 contains 1 shift/reduce conflicts.
transformqual -> 'then' 'group' . 'using' exp
transformqual -> 'then' 'group' . 'by' exp 'using' exp
@@ -340,7 +340,7 @@ state 992 contains 1 shift/reduce conflicts.
-------------------------------------------------------------------------------
-state 1089 contains 1 shift/reduce conflicts.
+state 1084 contains 1 shift/reduce conflicts.
rule_foralls -> 'forall' rule_vars '.' . 'forall' rule_vars '.'
*** rule_foralls -> 'forall' rule_vars '.' .
@@ -362,7 +362,15 @@ Shift means the parser only allows the former. Also see conflict 753 above.
-------------------------------------------------------------------------------
-state 1390 contains 1 shift/reduce conflict.
+state 1285 contains 1 shift/reduce conflict.
+
+ constrs1 -> constrs1 maybe_docnext '|' . maybe_docprev constr
+
+ Conflict: DOCPREV
+
+-------------------------------------------------------------------------------
+
+state 1375 contains 1 shift/reduce conflict.
*** atype -> tyvar .
tv_bndr -> '(' tyvar . '::' kind ')'
@@ -460,7 +468,6 @@ are the most common patterns, rewritten as regular expressions for clarity:
'data' { L _ ITdata }
'default' { L _ ITdefault }
'deriving' { L _ ITderiving }
- 'do' { L _ ITdo }
'else' { L _ ITelse }
'hiding' { L _ IThiding }
'if' { L _ ITif }
@@ -487,7 +494,6 @@ are the most common patterns, rewritten as regular expressions for clarity:
'safe' { L _ ITsafe }
'interruptible' { L _ ITinterruptible }
'unsafe' { L _ ITunsafe }
- 'mdo' { L _ ITmdo }
'family' { L _ ITfamily }
'role' { L _ ITrole }
'stdcall' { L _ ITstdcallconv }
@@ -581,6 +587,11 @@ are the most common patterns, rewritten as regular expressions for clarity:
QVARSYM { L _ (ITqvarsym _) }
QCONSYM { L _ (ITqconsym _) }
+
+ -- QualifiedDo
+ DO { L _ (ITdo _) }
+ MDO { L _ (ITmdo _) }
+
IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension
LABELVARID { L _ (ITlabelvarid _) }
@@ -2820,14 +2831,21 @@ aexp :: { ECP }
FromSource (snd $ unLoc $4)))
(mj AnnCase $1:mj AnnOf $3
:(fst $ unLoc $4)) }
- | 'do' stmtlist { ECP $
+ -- QualifiedDo.
+ | DO stmtlist {% do
+ hintQualifiedDo $1
+ return $ ECP $
$2 >>= \ $2 ->
- amms (mkHsDoPV (comb2 $1 $2) (mapLoc snd $2))
- (mj AnnDo $1:(fst $ unLoc $2)) }
- | 'mdo' stmtlist {% runPV $2 >>= \ $2 ->
+ amms (mkHsDoPV (comb2 $1 $2)
+ (fmap mkModuleNameFS (getDO $1))
+ (mapLoc snd $2))
+ (mj AnnDo $1:(fst $ unLoc $2)) }
+ | MDO stmtlist {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 ->
fmap ecpFromExp $
ams (L (comb2 $1 $2)
- (mkHsDo MDoExpr (snd $ unLoc $2)))
+ (mkHsDo (MDoExpr $
+ fmap mkModuleNameFS (getMDO $1))
+ (snd $ unLoc $2)))
(mj AnnMdo $1:(fst $ unLoc $2)) }
| 'proc' aexp '->' exp
{% (checkPattern <=< runECP_P) $2 >>= \ p ->
@@ -3836,6 +3854,8 @@ getVARID (L _ (ITvarid x)) = x
getCONID (L _ (ITconid x)) = x
getVARSYM (L _ (ITvarsym x)) = x
getCONSYM (L _ (ITconsym x)) = x
+getDO (L _ (ITdo x)) = x
+getMDO (L _ (ITmdo x)) = x
getQVARID (L _ (ITqvarid x)) = x
getQCONID (L _ (ITqconid x)) = x
getQVARSYM (L _ (ITqvarsym x)) = x
@@ -4029,6 +4049,23 @@ hintExplicitForall tok = do
where
forallSymDoc = text (forallSym (isUnicode tok))
+-- Hint about qualified-do
+hintQualifiedDo :: Located Token -> P ()
+hintQualifiedDo tok = do
+ qualifiedDo <- getBit QualifiedDoBit
+ case maybeQDoDoc of
+ Just qdoDoc | not qualifiedDo ->
+ addError (getLoc tok) $ vcat
+ [ text "Illegal qualified" <+> quotes qdoDoc <+> text "block"
+ , text "Perhaps you intended to use QualifiedDo"
+ ]
+ _ -> return ()
+ where
+ maybeQDoDoc = case unLoc tok of
+ ITdo (Just m) -> Just $ ftext m <> text ".do"
+ ITmdo (Just m) -> Just $ ftext m <> text ".mdo"
+ t -> Nothing
+
-- When two single quotes don't followed by tyvar or gtycon, we report the
-- error as empty character literal, or TH quote that missing proper type
-- variable or constructor. See #13450.
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index 2df6400a19..d9c2b09b8f 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -184,6 +184,11 @@ $docsym = [\| \^ \* \$]
@qvarsym = @qual @varsym
@qconsym = @qual @consym
+-- QualifiedDo needs to parse "M.do" not as a variable, so as to keep the
+-- layout rules.
+@qdo = @qual "do"
+@qmdo = @qual "mdo"
+
@floating_point = @numspc @decimal \. @decimal @exponent? | @numspc @decimal @exponent
@hex_floating_point = @numspc @hexadecimal \. @hexadecimal @bin_exponent? | @numspc @hexadecimal @bin_exponent
@@ -450,6 +455,8 @@ $tab { warnTab }
}
<0,option_prags> {
+ @qdo { qdo_token ITdo }
+ @qmdo / { ifExtension RecursiveDoBit } { qdo_token ITmdo }
@qvarid { idtoken qvarid }
@qconid { idtoken qconid }
@varid { varid }
@@ -674,7 +681,7 @@ data Token
| ITdata
| ITdefault
| ITderiving
- | ITdo
+ | ITdo (Maybe FastString)
| ITelse
| IThiding
| ITforeign
@@ -706,7 +713,7 @@ data Token
| ITcapiconv
| ITprimcallconv
| ITjavascriptcallconv
- | ITmdo
+ | ITmdo (Maybe FastString)
| ITfamily
| ITrole
| ITgroup
@@ -864,6 +871,7 @@ instance Outputable Token where
ppr x = text (show x)
+
-- the bitmap provided as the third component indicates whether the
-- corresponding extension keyword is valid under the extension options
-- provided to the compiler; if the extension corresponding to *any* of the
@@ -881,7 +889,7 @@ reservedWordsFM = listToUFM $
( "data", ITdata, 0 ),
( "default", ITdefault, 0 ),
( "deriving", ITderiving, 0 ),
- ( "do", ITdo, 0 ),
+ ( "do", ITdo Nothing, 0 ),
( "else", ITelse, 0 ),
( "hiding", IThiding, 0 ),
( "if", ITif, 0 ),
@@ -901,7 +909,7 @@ reservedWordsFM = listToUFM $
( "where", ITwhere, 0 ),
( "forall", ITforall NormalSyntax, 0),
- ( "mdo", ITmdo, xbit RecursiveDoBit),
+ ( "mdo", ITmdo Nothing, xbit RecursiveDoBit),
-- See Note [Lexing type pseudo-keywords]
( "family", ITfamily, 0 ),
( "role", ITrole, 0 ),
@@ -1015,6 +1023,13 @@ layout_token t span _buf _len = pushLexState layout >> return (L span t)
idtoken :: (StringBuffer -> Int -> Token) -> Action
idtoken f span buf len = return (L span $! (f buf len))
+qdo_token :: (Maybe FastString -> Token) -> Action
+qdo_token con span buf len = do
+ maybe_layout token
+ return (L span $! token)
+ where
+ !token = con $! Just $! fst $! splitQualName buf len False
+
skip_one_varid :: (FastString -> Token) -> Action
skip_one_varid f span buf len
= return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))
@@ -1390,6 +1405,8 @@ splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString)
-- takes a StringBuffer and a length, and returns the module name
-- and identifier parts of a qualified name. Splits at the *last* dot,
-- because of hierarchical module names.
+--
+-- Throws an error if the name is not qualified.
splitQualName orig_buf len parens = split orig_buf orig_buf
where
split buf dot_buf
@@ -1408,7 +1425,9 @@ splitQualName orig_buf len parens = split orig_buf orig_buf
where
(c,buf') = nextChar buf
- done dot_buf =
+ done dot_buf
+ | qual_size < 1 = error "splitQualName got an unqualified named"
+ | otherwise =
(lexemeToFastString orig_buf (qual_size - 1),
if parens -- Prelude.(+)
then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2)
@@ -1626,15 +1645,15 @@ maybe_layout t = do -- If the alternative layout rule is enabled then
-- context.
alr <- getBit AlternativeLayoutRuleBit
unless alr $ f t
- where f ITdo = pushLexState layout_do
- f ITmdo = pushLexState layout_do
- f ITof = pushLexState layout
- f ITlcase = pushLexState layout
- f ITlet = pushLexState layout
- f ITwhere = pushLexState layout
- f ITrec = pushLexState layout
- f ITif = pushLexState layout_if
- f _ = return ()
+ where f (ITdo _) = pushLexState layout_do
+ f (ITmdo _) = pushLexState layout_do
+ f ITof = pushLexState layout
+ f ITlcase = pushLexState layout
+ f ITlet = pushLexState layout
+ f ITwhere = pushLexState layout
+ f ITrec = pushLexState layout
+ f ITif = pushLexState layout_if
+ f _ = return ()
-- Pushing a new implicit layout context. If the indentation of the
-- next token is not greater than the previous layout context, then
@@ -2451,6 +2470,7 @@ data ExtBits
| HaddockBit-- Lex and parse Haddock comments
| MagicHashBit -- "#" in both functions and operators
| RecursiveDoBit -- mdo
+ | QualifiedDoBit -- .do and .mdo
| UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc
| UnboxedTuplesBit -- (# and #)
| UnboxedSumsBit -- (# and #)
@@ -2540,6 +2560,7 @@ mkParserFlags' warningFlags extensionFlags homeUnitId
.|. BangPatBit `xoptBit` LangExt.BangPatterns
.|. MagicHashBit `xoptBit` LangExt.MagicHash
.|. RecursiveDoBit `xoptBit` LangExt.RecursiveDo
+ .|. QualifiedDoBit `xoptBit` LangExt.QualifiedDo
.|. UnicodeSyntaxBit `xoptBit` LangExt.UnicodeSyntax
.|. UnboxedTuplesBit `xoptBit` LangExt.UnboxedTuples
.|. UnboxedSumsBit `xoptBit` LangExt.UnboxedSums
@@ -2864,14 +2885,14 @@ lexTokenAlr = do mPending <- popPendingImplicitToken
return t
setAlrLastLoc (getLoc t)
case unLoc t of
- ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere)
- ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet)
- ITof -> setAlrExpectingOCurly (Just ALRLayoutOf)
- ITlcase -> setAlrExpectingOCurly (Just ALRLayoutOf)
- ITdo -> setAlrExpectingOCurly (Just ALRLayoutDo)
- ITmdo -> setAlrExpectingOCurly (Just ALRLayoutDo)
- ITrec -> setAlrExpectingOCurly (Just ALRLayoutDo)
- _ -> return ()
+ ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere)
+ ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet)
+ ITof -> setAlrExpectingOCurly (Just ALRLayoutOf)
+ ITlcase -> setAlrExpectingOCurly (Just ALRLayoutOf)
+ ITdo _ -> setAlrExpectingOCurly (Just ALRLayoutDo)
+ ITmdo _ -> setAlrExpectingOCurly (Just ALRLayoutDo)
+ ITrec -> setAlrExpectingOCurly (Just ALRLayoutDo)
+ _ -> return ()
return t
alternativeLayoutRuleToken :: PsLocated Token -> P (PsLocated Token)
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 018ce7bb60..398bd78ddc 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -112,6 +112,7 @@ import GHC.Core.ConLike ( ConLike(..) )
import GHC.Core.Coercion.Axiom ( Role, fsFromRole )
import GHC.Types.Name.Reader
import GHC.Types.Name
+import GHC.Unit.Module (ModuleName)
import GHC.Types.Basic
import GHC.Parser.Lexer
import GHC.Utils.Lexeme ( isLexCon )
@@ -978,32 +979,33 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd)
where
checkExpr :: LHsExpr GhcPs -> PV ()
- checkExpr expr = case unLoc expr of
- HsDo _ DoExpr _ -> check "do block" expr
- HsDo _ MDoExpr _ -> check "mdo block" expr
- HsLam {} -> check "lambda expression" expr
- HsCase {} -> check "case expression" expr
- HsLamCase {} -> check "lambda-case expression" expr
- HsLet {} -> check "let expression" expr
- HsIf {} -> check "if expression" expr
- HsProc {} -> check "proc expression" expr
+ checkExpr expr = do
+ case unLoc expr of
+ HsDo _ (DoExpr m) _ -> check (prependQualified m (text "do block")) expr
+ HsDo _ (MDoExpr m) _ -> check (prependQualified m (text "mdo block")) expr
+ HsLam {} -> check (text "lambda expression") expr
+ HsCase {} -> check (text "case expression") expr
+ HsLamCase {} -> check (text "lambda-case expression") expr
+ HsLet {} -> check (text "let expression") expr
+ HsIf {} -> check (text "if expression") expr
+ HsProc {} -> check (text "proc expression") expr
_ -> return ()
checkCmd :: LHsCmd GhcPs -> PV ()
checkCmd cmd = case unLoc cmd of
- HsCmdLam {} -> check "lambda command" cmd
- HsCmdCase {} -> check "case command" cmd
- HsCmdIf {} -> check "if command" cmd
- HsCmdLet {} -> check "let command" cmd
- HsCmdDo {} -> check "do command" cmd
+ HsCmdLam {} -> check (text "lambda command") cmd
+ HsCmdCase {} -> check (text "case command") cmd
+ HsCmdIf {} -> check (text "if command") cmd
+ HsCmdLet {} -> check (text "let command") cmd
+ HsCmdDo {} -> check (text "do command") cmd
_ -> return ()
- check :: Outputable a => String -> Located a -> PV ()
+ check :: Outputable a => SDoc -> Located a -> PV ()
check element a = do
blockArguments <- getBit BlockArgumentsBit
unless blockArguments $
addError (getLoc a) $
- text "Unexpected " <> text element <> text " in function application:"
+ text "Unexpected " <> element <> text " in function application:"
$$ nest 4 (ppr a)
$$ text "You could write it with parentheses"
$$ text "Or perhaps you meant to enable BlockArguments?"
@@ -1814,7 +1816,11 @@ class b ~ (Body b) GhcPs => DisambECP b where
-> Located b
-> PV (Located b)
-- | Disambiguate "do { ... }" (do notation)
- mkHsDoPV :: SrcSpan -> Located [LStmt GhcPs (Located b)] -> PV (Located b)
+ mkHsDoPV ::
+ SrcSpan ->
+ Maybe ModuleName ->
+ Located [LStmt GhcPs (Located b)] ->
+ PV (Located b)
-- | Disambiguate "( ... )" (parentheses)
mkHsParPV :: SrcSpan -> Located b -> PV (Located b)
-- | Disambiguate a variable "f" or a data constructor "MkF".
@@ -1923,7 +1929,11 @@ instance DisambECP (HsCmd GhcPs) where
mkHsIfPV l c semi1 a semi2 b = do
checkDoAndIfThenElse c semi1 a semi2 b
return $ L l (mkHsCmdIf c a b)
- mkHsDoPV l stmts = return $ L l (HsCmdDo noExtField stmts)
+ mkHsDoPV l Nothing stmts = return $ L l (HsCmdDo noExtField stmts)
+ mkHsDoPV l (Just m) _ =
+ cmdFail l $
+ text "Found a qualified" <+> ppr m <> text ".do block in a command, but"
+ $$ text "qualified 'do' is not supported in commands."
mkHsParPV l c = return $ L l (HsCmdPar noExtField c)
mkHsVarPV (L l v) = cmdFail l (ppr v)
mkHsLitPV (L l a) = cmdFail l (ppr a)
@@ -1983,7 +1993,7 @@ instance DisambECP (HsExpr GhcPs) where
mkHsIfPV l c semi1 a semi2 b = do
checkDoAndIfThenElse c semi1 a semi2 b
return $ L l (mkHsIf c a b)
- mkHsDoPV l stmts = return $ L l (HsDo noExtField DoExpr stmts)
+ mkHsDoPV l mod stmts = return $ L l (HsDo noExtField (DoExpr mod) stmts)
mkHsParPV l e = return $ L l (HsPar noExtField e)
mkHsVarPV v@(getLoc -> l) = return $ L l (HsVar noExtField v)
mkHsLitPV (L l a) = return $ L l (HsLit noExtField a)
@@ -2065,7 +2075,7 @@ instance DisambECP (PatBuilder GhcPs) where
mkHsAppTypePV l _ _ = addFatalError l $
text "Type applications in patterns are not yet supported"
mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern"
- mkHsDoPV l _ = addFatalError l $ text "do-notation in pattern"
+ mkHsDoPV l _ _ = addFatalError l $ text "do-notation in pattern"
mkHsParPV l p = return $ L l (PatBuilderPar p)
mkHsVarPV v@(getLoc -> l) = return $ L l (PatBuilderVar v)
mkHsLitPV lit@(L l a) = do
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index 062a60088d..17deae7157 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -33,6 +33,10 @@ module GHC.Rename.Env (
lookupSyntax, lookupSyntaxExpr, lookupSyntaxName, lookupSyntaxNames,
lookupIfThenElse,
+ -- QualifiedDo
+ lookupQualifiedDoExpr, lookupQualifiedDo,
+ lookupQualifiedDoName, lookupNameWithQualifier,
+
-- Constructing usage information
addUsedGRE, addUsedGREs, addUsedDataCons,
@@ -1721,6 +1725,49 @@ lookupSyntaxNames std_names
do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names
; return (map (HsVar noExtField . noLoc) usr_names, mkFVs usr_names) } }
+{-
+Note [QualifiedDo]
+~~~~~~~~~~~~~~~~~~
+QualifiedDo is implemented using the same placeholders for operation names in
+the AST that were devised for RebindableSyntax. Whenever the renamer checks
+which names to use for do syntax, it first checks if the do block is qualified
+(e.g. M.do { stmts }), in which case it searches for qualified names. If the
+qualified names are not in scope, an error is produced. If the do block is not
+qualified, the renamer does the usual search of the names which considers
+whether RebindableSyntax is enabled or not. Dealing with QualifiedDo is driven
+by the Opt_QualifiedDo dynamic flag.
+-}
+
+-- Lookup operations for a qualified do. If the context is not a qualified
+-- do, then use lookupSyntaxExpr. See Note [QualifiedDo].
+lookupQualifiedDoExpr :: HsStmtContext p -> Name -> RnM (HsExpr GhcRn, FreeVars)
+lookupQualifiedDoExpr ctxt std_name
+ = first nl_HsVar <$> lookupQualifiedDoName ctxt std_name
+
+-- Like lookupQualifiedDoExpr but for producing SyntaxExpr.
+-- See Note [QualifiedDo].
+lookupQualifiedDo
+ :: HsStmtContext p
+ -> Name
+ -> RnM (SyntaxExpr GhcRn, FreeVars)
+lookupQualifiedDo ctxt std_name
+ = first mkSyntaxExpr <$> lookupQualifiedDoExpr ctxt std_name
+
+lookupNameWithQualifier :: Name -> ModuleName -> RnM (Name, FreeVars)
+lookupNameWithQualifier std_name modName
+ = do { qname <- lookupOccRn (mkRdrQual modName (nameOccName std_name))
+ ; return (qname, unitFV qname) }
+
+-- See Note [QualifiedDo].
+lookupQualifiedDoName
+ :: HsStmtContext p
+ -> Name
+ -> RnM (Name, FreeVars)
+lookupQualifiedDoName ctxt std_name
+ = case qualifiedDoModuleName_maybe ctxt of
+ Nothing -> lookupSyntaxName std_name
+ Just modName -> lookupNameWithQualifier std_name modName
+
-- Error messages
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index db05756067..2bfba1fb7f 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -54,6 +54,7 @@ import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Types.Unique.Set
import Data.List
+import Data.Maybe (isJust, isNothing)
import GHC.Utils.Misc
import GHC.Data.List.SetOps ( removeDups )
import GHC.Utils.Error
@@ -64,6 +65,7 @@ import Control.Monad
import GHC.Builtin.Types ( nilDataConName )
import qualified GHC.LanguageExtensions as LangExt
+import Control.Arrow (first)
import Data.Ord
import Data.Array
import qualified Data.List.NonEmpty as NE
@@ -696,7 +698,7 @@ postProcessStmtsForApplicativeDo ctxt stmts
-- -XApplicativeDo is on. Also strip out the FreeVars attached
-- to each Stmt body.
ado_is_on <- xoptM LangExt.ApplicativeDo
- ; let is_do_expr | DoExpr <- ctxt = True
+ ; let is_do_expr | DoExpr{} <- ctxt = True
| otherwise = False
-- don't apply the transformation inside TH brackets, because
-- GHC.HsToCore.Quote does not handle ApplicativeDo.
@@ -732,12 +734,12 @@ rnStmtsWithFreeVars ctxt _ [] thing_inside
; (thing, fvs) <- thing_inside []
; return (([], thing), fvs) }
-rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside -- Deal with mdo
+rnStmtsWithFreeVars mDoExpr@MDoExpr{} rnBody stmts thing_inside -- Deal with mdo
= -- Behave like do { rec { ...all but last... }; last }
do { ((stmts1, (stmts2, thing)), fvs)
- <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ ->
- do { last_stmt' <- checkLastStmt MDoExpr last_stmt
- ; rnStmt MDoExpr rnBody last_stmt' thing_inside }
+ <- rnStmt mDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ ->
+ do { last_stmt' <- checkLastStmt mDoExpr last_stmt
+ ; rnStmt mDoExpr rnBody last_stmt' thing_inside }
; return (((stmts1 ++ stmts2), thing), fvs) }
where
Just (all_but_last, last_stmt) = snocView stmts
@@ -809,7 +811,7 @@ rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside
rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside
= do { (body', fv_expr) <- rnBody body
- ; (then_op, fvs1) <- lookupStmtName ctxt thenMName
+ ; (then_op, fvs1) <- lookupQualifiedDoStmtName ctxt thenMName
; (guard_op, fvs2) <- if isComprehensionContext ctxt
then lookupStmtName ctxt guardMName
@@ -825,7 +827,7 @@ rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside
rnStmt ctxt rnBody (L loc (BindStmt _ pat body)) thing_inside
= do { (body', fv_expr) <- rnBody body
-- The binders do not scope over the expression
- ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
+ ; (bind_op, fvs1) <- lookupQualifiedDoStmtName ctxt bindMName
; (fail_op, fvs2) <- monadFailOp pat ctxt
@@ -845,9 +847,9 @@ rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside
, fvs) } }
rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
- = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName
- ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName
- ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName
+ = do { (return_op, fvs1) <- lookupQualifiedDoStmtName ctxt returnMName
+ ; (mfix_op, fvs2) <- lookupQualifiedDoStmtName ctxt mfixName
+ ; (bind_op, fvs3) <- lookupQualifiedDoStmtName ctxt bindMName
; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op
, recS_mfix_fn = mfix_op
, recS_bind_fn = bind_op }
@@ -861,7 +863,7 @@ rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
-- for which it's the fwd refs within the bind itself
-- (This set may not be empty, because we're in a recursive
-- context.)
- ; rnRecStmtsAndThen rnBody rec_stmts $ \ segs -> do
+ ; rnRecStmtsAndThen ctxt rnBody rec_stmts $ \ segs -> do
{ let bndrs = nameSetElemsStable $
foldr (unionNameSet . (\(ds,_,_,_) -> ds))
emptyNameSet
@@ -955,6 +957,14 @@ rnParallelStmts ctxt return_op segs thing_inside
dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"
<+> quotes (ppr (NE.head vs)))
+lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
+-- Like lookupStmtName, but respects QualifiedDo
+lookupQualifiedDoStmtName ctxt n
+ = case qualifiedDoModuleName_maybe ctxt of
+ Nothing -> lookupStmtName ctxt n
+ Just modName ->
+ first (mkSyntaxExpr . nl_HsVar) <$> lookupNameWithQualifier n modName
+
lookupStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
-- Like lookupSyntax, but respects contexts
lookupStmtName ctxt n
@@ -985,8 +995,8 @@ rebindableContext ctxt = case ctxt of
ArrowExpr -> False
PatGuard {} -> False
- DoExpr -> True
- MDoExpr -> True
+ DoExpr m -> isNothing m
+ MDoExpr m -> isNothing m
MonadComp -> True
GhciStmtCtxt -> True -- I suppose?
@@ -1031,7 +1041,8 @@ type Segment stmts = (Defs,
-- wrapper that does both the left- and right-hand sides
rnRecStmtsAndThen :: Outputable (body GhcPs) =>
- (Located (body GhcPs)
+ HsStmtContext GhcRn
+ -> (Located (body GhcPs)
-> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-- assumes that the FreeVars returned includes
@@ -1039,7 +1050,7 @@ rnRecStmtsAndThen :: Outputable (body GhcPs) =>
-> ([Segment (LStmt GhcRn (Located (body GhcRn)))]
-> RnM (a, FreeVars))
-> RnM (a, FreeVars)
-rnRecStmtsAndThen rnBody s cont
+rnRecStmtsAndThen ctxt rnBody s cont
= do { -- (A) Make the mini fixity env for all of the stmts
fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
@@ -1055,7 +1066,7 @@ rnRecStmtsAndThen rnBody s cont
addLocalFixities fix_env bound_names $ do
-- (C) do the right-hand-sides and thing-inside
- { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv
+ { segs <- rn_rec_stmts ctxt rnBody bound_names new_lhs_and_fv
; (res, fvs) <- cont segs
; mapM_ (\(loc, ns) -> checkUnusedRecordWildcard loc fvs (Just ns))
rec_uses
@@ -1135,30 +1146,31 @@ rn_rec_stmts_lhs fix_env stmts
-- right-hand-sides
rn_rec_stmt :: (Outputable (body GhcPs)) =>
- (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+ HsStmtContext GhcRn
+ -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [Name]
-> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
-> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
-- Rename a Stmt that is inside a RecStmt (or mdo)
-- Assumes all binders are already in scope
-- Turns each stmt into a singleton Stmt
-rn_rec_stmt rnBody _ (L loc (LastStmt _ body noret _), _)
+rn_rec_stmt ctxt rnBody _ (L loc (LastStmt _ body noret _), _)
= do { (body', fv_expr) <- rnBody body
- ; (ret_op, fvs1) <- lookupSyntax returnMName
+ ; (ret_op, fvs1) <- lookupQualifiedDo ctxt returnMName
; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
L loc (LastStmt noExtField body' noret ret_op))] }
-rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _)
+rn_rec_stmt ctxt rnBody _ (L loc (BodyStmt _ body _ _), _)
= do { (body', fvs) <- rnBody body
- ; (then_op, fvs1) <- lookupSyntax thenMName
+ ; (then_op, fvs1) <- lookupQualifiedDo ctxt thenMName
; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
L loc (BodyStmt noExtField body' then_op noSyntaxExpr))] }
-rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body), fv_pat)
+rn_rec_stmt ctxt rnBody _ (L loc (BindStmt _ pat' body), fv_pat)
= do { (body', fv_expr) <- rnBody body
- ; (bind_op, fvs1) <- lookupSyntax bindMName
+ ; (bind_op, fvs1) <- lookupQualifiedDo ctxt bindMName
- ; (fail_op, fvs2) <- getMonadFailOp
+ ; (fail_op, fvs2) <- getMonadFailOp ctxt
; let bndrs = mkNameSet (collectPatBinders pat')
fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
@@ -1166,10 +1178,10 @@ rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body), fv_pat)
; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
L loc (BindStmt xbsrn pat' body'))] }
-rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)
+rn_rec_stmt _ _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)
= failWith (badIpBinds (text "an mdo expression") binds)
-rn_rec_stmt _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _)
+rn_rec_stmt _ _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _)
= do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
-- fixities and unused are handled above in rnRecStmtsAndThen
; let fvs = allUses du_binds
@@ -1177,28 +1189,29 @@ rn_rec_stmt _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _)
L loc (LetStmt noExtField (L l (HsValBinds x binds'))))] }
-- no RecStmt case because they get flattened above when doing the LHSes
-rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)
+rn_rec_stmt _ _ _ stmt@(L _ (RecStmt {}), _)
= pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
-rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo
+rn_rec_stmt _ _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
-rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo
+rn_rec_stmt _ _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
-rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _)
+rn_rec_stmt _ _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _)
= panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
-rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)
+rn_rec_stmt _ _ _ stmt@(L _ (ApplicativeStmt {}), _)
= pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
rn_rec_stmts :: Outputable (body GhcPs) =>
- (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+ HsStmtContext GhcRn
+ -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [Name]
-> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
-> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
-rn_rec_stmts rnBody bndrs stmts
- = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts
+rn_rec_stmts ctxt rnBody bndrs stmts
+ = do { segs_s <- mapM (rn_rec_stmt ctxt rnBody bndrs) stmts
; return (concat segs_s) }
---------------------------------------------
@@ -1211,7 +1224,7 @@ segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
| null segs
= ([], fvs_later)
- | MDoExpr <- ctxt
+ | 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
@@ -1501,7 +1514,7 @@ ApplicativeDo touches a few phases in the compiler:
-}
-- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and
--- 'pureName' due to @RebindableSyntax@.
+-- 'pureName' due to @QualifiedDo@ or @RebindableSyntax@.
data MonadNames = MonadNames { return_name, pure_name :: Name }
instance Outputable MonadNames where
@@ -1528,8 +1541,8 @@ rearrangeForApplicativeDo ctxt stmts0 = do
let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts
| otherwise = mkStmtTreeHeuristic stmts
traceRn "rearrangeForADo" (ppr stmt_tree)
- (return_name, _) <- lookupSyntaxName returnMName
- (pure_name, _) <- lookupSyntaxName pureAName
+ (return_name, _) <- lookupQualifiedDoName ctxt returnMName
+ (pure_name, _) <- lookupQualifiedDoName ctxt pureAName
let monad_names = MonadNames { return_name = return_name
, pure_name = pure_name }
stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs
@@ -1726,7 +1739,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
if | L _ ApplicativeStmt{} <- last stmts' ->
return (unLoc tup, emptyNameSet)
| otherwise -> do
- (ret, _) <- lookupSyntaxExpr returnMName
+ (ret, _) <- lookupQualifiedDoExpr ctxt returnMName
let expr = HsApp noExtField (noLoc ret) tup
return (expr, emptyFVs)
return ( ApplicativeArgMany
@@ -1734,6 +1747,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
, app_stmts = stmts'
, final_expr = mb_ret
, bv_pattern = pat
+ , stmt_context = ctxt
}
, fvs1 `plusFV` fvs2)
@@ -1925,11 +1939,11 @@ mkApplicativeStmt
-> [ExprLStmt GhcRn] -- ^ The body statements
-> RnM ([ExprLStmt GhcRn], FreeVars)
mkApplicativeStmt ctxt args need_join body_stmts
- = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName
- ; (ap_op, fvs2) <- lookupStmtName ctxt apAName
+ = do { (fmap_op, fvs1) <- lookupQualifiedDoStmtName ctxt fmapName
+ ; (ap_op, fvs2) <- lookupQualifiedDoStmtName ctxt apAName
; (mb_join, fvs3) <-
if need_join then
- do { (join_op, fvs) <- lookupStmtName ctxt joinMName
+ do { (join_op, fvs) <- lookupQualifiedDoStmtName ctxt joinMName
; return (Just join_op, fvs) }
else
return (Nothing, emptyNameSet)
@@ -2003,8 +2017,8 @@ checkLastStmt ctxt lstmt@(L loc stmt)
ListComp -> check_comp
MonadComp -> check_comp
ArrowExpr -> check_do
- DoExpr -> check_do
- MDoExpr -> check_do
+ DoExpr{} -> check_do
+ MDoExpr{} -> check_do
_ -> check_other
where
check_do -- Expect BodyStmt, and change it to LastStmt
@@ -2061,8 +2075,8 @@ 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
+ DoExpr{} -> okDoStmt dflags ctxt stmt
+ MDoExpr{} -> okDoStmt dflags ctxt stmt
ArrowExpr -> okDoStmt dflags ctxt stmt
GhciStmtCtxt -> okDoStmt dflags ctxt stmt
ListComp -> okCompStmt dflags ctxt stmt
@@ -2144,9 +2158,9 @@ monadFailOp pat ctxt
-- For non-monadic contexts (e.g. guard patterns, list
-- comprehensions, etc.) we should not need to fail, or failure is handled in
-- a different way. See Note [Failing pattern matches in Stmts].
- | not (isMonadFailStmtContext ctxt) = return (Nothing, emptyFVs)
+ | not (isMonadStmtContext ctxt) = return (Nothing, emptyFVs)
- | otherwise = getMonadFailOp
+ | otherwise = getMonadFailOp ctxt
{-
Note [Monad fail : Rebindable syntax, overloaded strings]
@@ -2171,18 +2185,32 @@ So, in this case, we synthesize the function
(rather than plain 'fail') for the 'fail' operation. This is done in
'getMonadFailOp'.
+
+Similarly with QualifiedDo and OverloadedStrings, we also want to desugar
+using fromString:
+
+ foo x = M.do { Just y <- x; return y }
+
+ ===>
+
+ foo x = x M.>>= \r -> case r of
+ Just y -> return y
+ Nothing -> M.fail (fromString "Pattern match error")
+
-}
-getMonadFailOp :: RnM (FailOperator GhcRn, FreeVars) -- Syntax expr fail op
-getMonadFailOp
+getMonadFailOp :: HsStmtContext p -> RnM (FailOperator GhcRn, FreeVars) -- Syntax expr fail op
+getMonadFailOp ctxt
= do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags
; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags
; (fail, fvs) <- reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings
; return (Just fail, fvs)
}
where
+ isQualifiedDo = isJust (qualifiedDoModuleName_maybe ctxt)
+
reallyGetMonadFailOp rebindableSyntax overloadedStrings
- | rebindableSyntax && overloadedStrings = do
- (failExpr, failFvs) <- lookupSyntaxExpr failMName
+ | (isQualifiedDo || rebindableSyntax) && overloadedStrings = do
+ (failExpr, failFvs) <- lookupQualifiedDoExpr ctxt failMName
(fromStringExpr, fromStringFvs) <- lookupSyntaxExpr fromStringName
let arg_lit = mkVarOcc "arg"
arg_name <- newSysName arg_lit
@@ -2195,4 +2223,4 @@ getMonadFailOp
let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =
mkSyntaxExpr failAfterFromStringExpr
return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
- | otherwise = lookupSyntax failMName
+ | otherwise = lookupQualifiedDo ctxt failMName
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 1fe58c0414..08f6fab20c 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -984,7 +984,7 @@ gen_Read_binds get_fixity loc tycon
read_nullary_cons
= case nullary_cons of
[] -> []
- [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
+ [con] -> [nlHsDo (DoExpr Nothing) (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
_ -> [nlHsApp (nlHsVar choose_RDR)
(nlList (map mk_pair nullary_cons))]
-- NB For operators the parens around (:=:) are matched by the
@@ -1058,7 +1058,7 @@ gen_Read_binds get_fixity loc tycon
------------------------------------------------------------------------
mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b })
- , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]
+ , nlHsDo (DoExpr Nothing) (ss ++ [noLoc $ mkLastStmt b])]
con_app con as = nlHsVarApps (getRdrName con) as -- con as
result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index 8d7e5e8c2c..39dae3bf95 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -316,15 +316,15 @@ tcDoStmts ListComp (L l stmts) res_ty
(mkCheckExpType elt_ty)
; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
-tcDoStmts DoExpr (L l stmts) res_ty
- = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
+tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty
+ = do { stmts' <- tcStmts doExpr tcDoStmt stmts res_ty
; res_ty <- readExpType res_ty
- ; return (HsDo res_ty DoExpr (L l stmts')) }
+ ; return (HsDo res_ty doExpr (L l stmts')) }
-tcDoStmts MDoExpr (L l stmts) res_ty
- = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty
+tcDoStmts mDoExpr@(MDoExpr _) (L l stmts) res_ty
+ = do { stmts' <- tcStmts mDoExpr tcDoStmt stmts res_ty
; res_ty <- readExpType res_ty
- ; return (HsDo res_ty MDoExpr (L l stmts')) }
+ ; return (HsDo res_ty mDoExpr (L l stmts')) }
tcDoStmts MonadComp (L l stmts) res_ty
= do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
@@ -1063,7 +1063,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
, .. }
) }
- goArg _body_ty (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty)
+ goArg _body_ty (ApplicativeArgMany x stmts ret pat ctxt, pat_ty, exp_ty)
= do { (stmts', (ret',pat')) <-
tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $
\res_ty -> do
@@ -1072,7 +1072,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
return ()
; return (ret', pat')
}
- ; return (ApplicativeArgMany x stmts' ret' pat') }
+ ; return (ApplicativeArgMany x stmts' ret' pat' ctxt) }
get_arg_bndrs :: ApplicativeArg GhcTc -> [Id]
get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 17bdb42c3a..a65cf6564e 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -1228,15 +1228,15 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
get_pat :: (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> LPat GhcTc
get_pat (_, ApplicativeArgOne _ pat _ _) = pat
- get_pat (_, ApplicativeArgMany _ _ _ pat) = pat
+ get_pat (_, ApplicativeArgMany _ _ _ pat _) = pat
replace_pat :: LPat GhcTc
-> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
replace_pat pat (op, ApplicativeArgOne fail_op _ a isBody)
= (op, ApplicativeArgOne fail_op pat a isBody)
- replace_pat pat (op, ApplicativeArgMany x a b _)
- = (op, ApplicativeArgMany x a b pat)
+ replace_pat pat (op, ApplicativeArgMany x a b _ c)
+ = (op, ApplicativeArgMany x a b pat c)
zonk_args env args
= do { (env1, new_args_rev) <- zonk_args_rev env (reverse args)
@@ -1261,10 +1261,10 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
; return fail'
}
; return (ApplicativeArgOne new_fail pat new_expr isBody) }
- zonk_arg env (ApplicativeArgMany x stmts ret pat)
+ zonk_arg env (ApplicativeArgMany x stmts ret pat ctxt)
= do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
; new_ret <- zonkExpr env1 ret
- ; return (ApplicativeArgMany x new_stmts new_ret pat) }
+ ; return (ApplicativeArgMany x new_stmts new_ret pat ctxt) }
-------------------------------------------------------------------------
zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTc -> TcM (HsRecordBinds GhcTc)
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 75bd004dc1..58add2b135 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -956,8 +956,8 @@ cvtl e = wrapL (cvt e)
; th_origin <- getOrigin
; return $ HsCase noExtField e'
(mkMatchGroup th_origin ms') }
- cvt (DoE ss) = cvtHsDo DoExpr ss
- cvt (MDoE ss) = cvtHsDo MDoExpr ss
+ cvt (DoE m ss) = cvtHsDo (DoExpr (mk_mod <$> m)) ss
+ cvt (MDoE m ss) = cvtHsDo (MDoExpr (mk_mod <$> m)) ss
cvt (CompE ss) = cvtHsDo ListComp ss
cvt (ArithSeqE dd) = do { dd' <- cvtDD dd
; return $ ArithSeq noExtField Nothing dd' }
View Lorry Controller Status