Commit 9ee58f8d authored by Matthías Páll Gissurarson's avatar Matthías Páll Gissurarson Committed by Facundo Domínguez

Implement the proposed -XQualifiedDo extension

Co-authored-by: default avatarFacundo 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.
parent a3d69dc6
Pipeline #21555 passed with stages
in 1170 minutes and 57 seconds
......@@ -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 = ...
......
......@@ -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,
......
......@@ -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"
......
......@@ -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)
......
......@@ -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)
......
......@@ -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)
......
......@@ -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,
......
......@@ -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] }
......
......@@ -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]
......
......@@ -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
]
......
......@@ -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 ()