summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorMatthias Pall Gissurarson <mpg@mpg.is>2020-05-19 22:50:47 +0200
committerFacundo Domínguez <facundo.dominguez@tweag.io>2020-06-26 17:12:45 +0000
commit9ee58f8d900884ac8b721b6b95dbfa6500f39431 (patch)
tree2025e2f3ef4a92b252059287ea5d84745eec1118 /compiler
parenta3d69dc6c2134afe239caf4f881ba5542d2c2be0 (diff)
downloadhaskell-9ee58f8d900884ac8b721b6b95dbfa6500f39431.tar.gz
Implement the proposed -XQualifiedDo extension
Co-authored-by: Facundo Domínguez <facundo.dominguez@tweag.io> 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 in the module M. This allows users to write {-# LANGUAGE QualifiedDo #-} import qualified SomeModule as M f x = M.do -- desugars to: y <- M.return x -- M.return x M.>>= \y -> M.return y -- M.return y M.>> M.return y -- M.return y See Note [QualifiedDo] and the users' guide for more details. Issue #18214 Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0216-qualified-do.rst Since we change the constructors `ITdo` and `ITmdo` to carry the new module name, we need to bump the haddock submodule to account or the new shape of these constructors.
Diffstat (limited to 'compiler')
-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' }