diff options
| author | Matthias Pall Gissurarson <mpg@mpg.is> | 2020-05-19 22:50:47 +0200 |
|---|---|---|
| committer | Facundo Domínguez <facundo.dominguez@tweag.io> | 2020-06-26 17:12:45 +0000 |
| commit | 9ee58f8d900884ac8b721b6b95dbfa6500f39431 (patch) | |
| tree | 2025e2f3ef4a92b252059287ea5d84745eec1118 | |
| parent | a3d69dc6c2134afe239caf4f881ba5542d2c2be0 (diff) | |
| download | haskell-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.
69 files changed, 1083 insertions, 203 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' } diff --git a/docs/users_guide/8.12.1-notes.rst b/docs/users_guide/8.12.1-notes.rst index 1bf9464db4..deb29310ff 100644 --- a/docs/users_guide/8.12.1-notes.rst +++ b/docs/users_guide/8.12.1-notes.rst @@ -150,6 +150,20 @@ Language data U a where MkU :: (Show a => U a) +* A new language extension :extension:`QualifiedDo` is implemented, allowing + to qualify a do block to control which operations to use for desugaring do + syntax. :: + + {-# 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 :ref:`qualified-do-notation` for more details. + Compiler ~~~~~~~~ diff --git a/docs/users_guide/exts/qualified_do.rst b/docs/users_guide/exts/qualified_do.rst new file mode 100644 index 0000000000..752628f379 --- /dev/null +++ b/docs/users_guide/exts/qualified_do.rst @@ -0,0 +1,186 @@ +.. _qualified-do-notation: + +Qualified do-notation +------------------------- + +.. index:: + single: Qualified do-notation + single: do-notation; Qualified + +.. extension:: QualifiedDo + :shortdesc: Enable qualified do-notation desugaring. + + :since: 8.12.1 + + Allow the use of qualified ``do`` notation. + +``QualifiedDo`` enables qualifying a ``do`` block with a module name, to control which operations to use for +the monadic combinators that the ``do`` notation desugars to. +When ``-XQualifiedDo`` is enabled, you can *qualify* the ``do`` notation by writing ``modid.do``, where +``modid`` is a module name in scope: :: + + {-# LANGAUGE QualifiedDo #-} + import qualified Some.Module.Monad as M + + action :: M.SomeType a + action = M.do x <- u + res + M.return x + +The additional module name (here ``M``) is called the qualifier of the do-expression. + +The unqualified ``do`` syntax is convenient for writing monadic code, but +it only works for data types that provide an instance of the ``Monad`` type class. +There are other types which are "monad-like" but can't provide an instance of +``Monad`` (e.g. indexed monads, graded monads or relative monads), yet they could +still use the ``do`` syntax if it weren't hardwired to the methods of the ``Monad`` +type class. ``-XQualifiedDo`` comes to make the do syntax customizable in this +respect. +It allows you to mix and match ``do`` blocks of different types with suitable +operations to use on each case: :: + + {-# LANGUAGE QualifiedDo #-} + import qualified Control.Monad.Linear as L + + import MAC (label, box, runMAC) + import qualified MAC as MAC + + f :: IO () + f = do + x <- runMAC $ -- (Prelude.>>=) + -- (runMAC $ + MAC.do -- + d <- label "y" -- label "y" MAC.>>= \d -> + box $ -- + -- (box $ + L.do -- + r <- L.f d -- L.f d L.>>= \r -> + L.g r -- L.g r L.>> + L.return r -- L.return r + -- ) MAC.>> + MAC.return d -- (MAC.return d) + -- ) + print x -- (\x -> print x) + +The semantics of ``do`` notation statements with ``-XQualifiedDo`` is as follows: + +* The ``x <- u`` statement uses ``(M.>>=)`` :: + + M.do { x <- u; stmts } = u M.>>= \x -> M.do { stmts } + +* The ``u`` statement uses ``(M.>>)`` :: + + M.do { u; stmts } = u M.>> M.do { stmts } + +* The a ``pat <- u`` statement uses ``M.fail`` for the failing case, + if such a case is needed :: + + M.do { pat <- u; stmts } = u M.>>= \case + { pat -> M.do { stmts } + ; _ -> M.fail "…" + } + + If the pattern cannot fail, then we don't need to use ``M.fail``. :: + + M.do { pat <- u; stmts } = u M.>>= \case pat -> M.do { stmts } + +* The desugaring of ``-XApplicativeDo`` uses ``(M.<$>)``, ``(M.<*>)``, + and ``M.join`` (after the the applicative-do grouping has been performed) :: + + M.do { (x1 <- u1 | … | xn <- un); M.return e } = + (\x1 … xn -> e) M.<$> u1 M.<*> … M.<*> un + + M.do { (x1 <- u1 | … | xn <- un); stmts } = + M.join ((\x1 … xn -> M.do { stmts }) M.<$> u1 M.<*> … M.<*> un) + + Note that ``M.join`` is only needed if the final expression is not + identifiably a ``return``. With ``-XQualifiedDo`` enabled, ``-XApplicativeDo`` + looks only for the qualified ``return``/``pure`` in a qualified do-block. + +* With ``-XRecursiveDo``, ``rec`` and ``mdo`` blocks use ``M.mfix`` and ``M.return``: :: + + M.do { rec { x1 <- u1; … ; xn <- un }; stmts } = + M.do + { (x1, …, xn) <- M.mfix (\~(x1, …, xn) -> M.do { x1 <- u1; …; xn <- un; M.return (x1, …, xn)}) + ; stmts + } + +If a name ``M.op`` is required by the desugaring process (and only if it's required!) but the name is +not in scope, it is reported as an error. + +The types of the operations picked for desugaring must produce an +expression which is accepted by the typechecker. But other than that, +there are no specific requirements on the types. + +If no qualifier is specified with ``-XQualifiedDo`` enabled, it defaults to the operations defined in the Prelude, or, if +``-XRebindableSyntax`` is enabled, to whatever operations are in scope. + +Note that the operations to be qualified must be in scope for QualifiedDo to work. I.e. ``import MAC (label)`` in the +example above would result in an error, since ``MAC.>>=`` and ``MAC.>>`` would not be in scope. + +Examples +~~~~~~~~ + +``-XQualifiedDo`` does not affect ``return`` in the monadic ``do`` notation. :: + + import qualified Some.Monad.M as M + + boolM :: (a -> M.M Bool) -> b -> b -> a -> M.M b + boolM p a b x = M.do + px <- p x -- M.>>= + if px then + return b -- Prelude.return + else + M.return a -- M.return + +``-XQualifiedDo`` does not affect explicit ``(>>=)`` in the monadic ``do`` notation. :: + + import qualified Some.Monad.M as M + import Data.Bool (bool) + + boolMM :: (a -> M.M Bool) -> M b -> M b -> a -> M.M b + boolMM p ma mb x = M.do + p x >>= bool ma mb -- Prelude.>>= + +Nested ``do`` blocks do not affect each other's meanings. :: + + import qualified Some.Monad.M as M + + f :: M.M SomeType + f = M.do + x <- f1 -- M.>>= + f2 (do y <- g1 -- Prelude.>>= + g2 x y) + where + f1 = ... + f2 m = ... + g1 = ... + g2 x y = ... + +The type of ``(>>=)`` can also be modified, as seen here for a graded monad: :: + + {-# LANGUAGE ConstraintKinds #-} + {-# LANGUAGE PolyKinds #-} + {-# LANGUAGE TypeFamilies #-} + module Control.Monad.Graded (GradedMonad(..)) where + + import Data.Kind (Constraint) + + class GradedMonad (m :: k -> * -> *) where + type Unit m :: k + type Plus m (i :: k) (j :: k) :: k + type Inv m (i :: k) (j :: k) :: Constraint + (>>=) :: Inv m i j => m i a -> (a -> m j b) -> m (Plus m i j) b + return :: a -> m (Unit m) a + + ----------------- + + module M where + + import Control.Monad.Graded as Graded + + g :: GradedMonad m => a -> m SomeTypeIndex b + g a = Graded.do + b <- someGradedFunction a Graded.>>= someOtherGradedFunction + c <- anotherGradedFunction b + Graded.return c diff --git a/docs/users_guide/exts/syntax.rst b/docs/users_guide/exts/syntax.rst index 9fc8d366a9..781e65b9d3 100644 --- a/docs/users_guide/exts/syntax.rst +++ b/docs/users_guide/exts/syntax.rst @@ -10,6 +10,7 @@ Syntax magic_hash recursive_do applicative_do + qualified_do parallel_list_comprehensions generalised_list_comprehensions monad_comprehensions diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs index b7c3ba3a1a..e7ef699c68 100644 --- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs @@ -43,6 +43,7 @@ data Extension | Arrows -- Arrow-notation syntax | TemplateHaskell | TemplateHaskellQuotes -- subset of TH supported by stage1, no splice + | QualifiedDo | QuasiQuotes | ImplicitParams | ImplicitPrelude diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 4c4eaf5dbe..7aa4761321 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -157,12 +157,15 @@ import Language.Haskell.TH.Lib.Internal hiding , derivClause , standaloneDerivWithStrategyD + , doE + , mdoE , tupE , unboxedTupE , Role , InjectivityAnn ) +import qualified Language.Haskell.TH.Lib.Internal as Internal import Language.Haskell.TH.Syntax import Control.Applicative ( liftA2 ) @@ -337,3 +340,12 @@ tupE es = do { es1 <- sequenceA es; return (TupE $ map Just es1)} unboxedTupE :: Quote m => [m Exp] -> m Exp unboxedTupE es = do { es1 <- sequenceA es; return (UnboxedTupE $ map Just es1)} + +------------------------------------------------------------------------------- +-- * Do expressions + +doE :: Quote m => [m Stmt] -> m Exp +doE = Internal.doE Nothing + +mdoE :: Quote m => [m Stmt] -> m Exp +mdoE = Internal.mdoE Nothing diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs index ff020ee62d..c93cc6c3a8 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -312,11 +312,11 @@ letE ds e = do { ds2 <- sequenceA ds; e2 <- e; pure (LetE ds2 e2) } caseE :: Quote m => m Exp -> [m Match] -> m Exp caseE e ms = do { e1 <- e; ms1 <- sequenceA ms; pure (CaseE e1 ms1) } -doE :: Quote m => [m Stmt] -> m Exp -doE ss = do { ss1 <- sequenceA ss; pure (DoE ss1) } +doE :: Quote m => Maybe ModName -> [m Stmt] -> m Exp +doE m ss = do { ss1 <- sequenceA ss; pure (DoE m ss1) } -mdoE :: Quote m => [m Stmt] -> m Exp -mdoE ss = do { ss1 <- sequenceA ss; pure (MDoE ss1) } +mdoE :: Quote m => Maybe ModName -> [m Stmt] -> m Exp +mdoE m ss = do { ss1 <- sequenceA ss; pure (MDoE m ss1) } compE :: Quote m => [m Stmt] -> m Exp compE ss = do { ss1 <- sequenceA ss; pure (CompE ss1) } diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index fcaaa40c3e..337017a958 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -182,13 +182,19 @@ pprExp i (LetE ds_ e) = parensIf (i > noPrec) $ text "let" <+> pprDecs ds_ pprExp i (CaseE e ms) = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of" $$ nest nestDepth (ppr ms) -pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_ +pprExp i (DoE m ss_) = parensIf (i > noPrec) $ + pprQualifier m <> text "do" <+> pprStms ss_ where + pprQualifier Nothing = empty + pprQualifier (Just modName) = text (modString modName) <> char '.' pprStms [] = empty pprStms [s] = ppr s pprStms ss = braces (semiSep ss) -pprExp i (MDoE ss_) = parensIf (i > noPrec) $ text "mdo" <+> pprStms ss_ +pprExp i (MDoE m ss_) = parensIf (i > noPrec) $ + pprQualifier m <> text "mdo" <+> pprStms ss_ where + pprQualifier Nothing = empty + pprQualifier (Just modName) = text (modString modName) <> char '.' pprStms [] = empty pprStms [s] = ppr s pprStms ss = braces (semiSep ss) diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 955f430d33..a894ce8378 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -2039,8 +2039,10 @@ data Exp | MultiIfE [(Guard, Exp)] -- ^ @{ if | g1 -> e1 | g2 -> e2 }@ | LetE [Dec] Exp -- ^ @{ let { x=e1; y=e2 } in e3 }@ | CaseE Exp [Match] -- ^ @{ case e of m1; m2 }@ - | DoE [Stmt] -- ^ @{ do { p <- e1; e2 } }@ - | MDoE [Stmt] -- ^ @{ mdo { x <- e1 y; y <- e2 x; } }@ + | DoE (Maybe ModName) [Stmt] -- ^ @{ do { p <- e1; e2 } }@ or a qualified do if + -- the module name is present + | MDoE (Maybe ModName) [Stmt] -- ^ @{ mdo { x <- e1 y; y <- e2 x; } }@ or a qualified + -- mdo if the module name is present | CompE [Stmt] -- ^ @{ [ (x,y) | x <- xs, y <- ys ] }@ -- -- The result expression of the comprehension is diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index d3eaa00b4c..0b3aa8d079 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -9,7 +9,7 @@ written in terms of `Q` are now disallowed. The types of `unsafeTExpCoerce` and `unTypeQ` are also generalised in terms of `Quote` rather than specific to `Q`. - + * Implement Explicit specificity in type variable binders (GHC Proposal #99). In `Language.Haskell.TH.Syntax`, `TyVarBndr` is now annotated with a `flag`, denoting the additional argument to its constructors `PlainTV` and `KindedTV`. @@ -26,6 +26,9 @@ * Add `MonadFix` instance for `Q` (#12073). + * Add support for QualifiedDo. The data constructors `DoE` and `MDoE` got a new + `Maybe ModName` argument to describe the qualifier of do blocks. + ## 2.16.0.0 *TBA* * Add support for tuple sections. (#15843) The type signatures of `TupE` and diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index c1c9502863..9a11780dc5 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -41,6 +41,7 @@ expectedGhcOnlyExtensions = , "AlternativeLayoutRule" , "AlternativeLayoutRuleTransitional" , "LinearTypes" + , "QualifiedDo" ] expectedCabalOnlyExtensions :: [String] diff --git a/testsuite/tests/qualifieddo/Makefile b/testsuite/tests/qualifieddo/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/qualifieddo/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/qualifieddo/should_compile/Makefile b/testsuite/tests/qualifieddo/should_compile/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/qualifieddo/should_compile/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/qualifieddo/should_compile/all.T b/testsuite/tests/qualifieddo/should_compile/all.T new file mode 100644 index 0000000000..a22dc0a4dc --- /dev/null +++ b/testsuite/tests/qualifieddo/should_compile/all.T @@ -0,0 +1,4 @@ +setTestOpts(only_ways(['normal'])); + +test('qdocompile001', normal, compile, ['-v0 -ddump-rn -dsuppress-uniques']) +test('qdocompile002', normal, compile, ['-v0']) diff --git a/testsuite/tests/qualifieddo/should_compile/qdocompile001.hs b/testsuite/tests/qualifieddo/should_compile/qdocompile001.hs new file mode 100644 index 0000000000..a9b749c170 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_compile/qdocompile001.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE QualifiedDo #-} + +import Prelude as P + +-- Test that the context of the do shows well in the renamer +-- output. +-- +-- The nested do in the renamer output must be qualified the +-- same as the outer P.do written in the source program. +-- +-- > ==================== Renamer ==================== +-- > Main.main +-- > = print +-- > $ P.do (x <- [1, 2] | +-- > y <- P.do y@1 <- [1, 2] -- qualified! +-- > [1, 2] +-- > y) +-- > return y +-- +main = + print $ P.do + x <- [1, 2] + y@1 <- [1, 2] + [1, 2] + P.return y diff --git a/testsuite/tests/qualifieddo/should_compile/qdocompile001.stderr b/testsuite/tests/qualifieddo/should_compile/qdocompile001.stderr new file mode 100644 index 0000000000..da47e331c9 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_compile/qdocompile001.stderr @@ -0,0 +1,9 @@ + +==================== Renamer ==================== +Main.main + = print + $ P.do (x <- [1, 2] | + y <- P.do y@1 <- [1, 2] + [1, 2] + y) + return y diff --git a/testsuite/tests/qualifieddo/should_compile/qdocompile002.hs b/testsuite/tests/qualifieddo/should_compile/qdocompile002.hs new file mode 100644 index 0000000000..bbbee88ac5 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_compile/qdocompile002.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE QualifiedDo #-} + +import Prelude as P hiding (fail) + + +-- Tests that fail is not required with irrefutable patterns +main = + print $ P.do + x <- [1, 2] + (_, y) <- [(1, "a"), (2, "b")] + P.return (x, y) diff --git a/testsuite/tests/qualifieddo/should_fail/Makefile b/testsuite/tests/qualifieddo/should_fail/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/qualifieddo/should_fail/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/qualifieddo/should_fail/all.T b/testsuite/tests/qualifieddo/should_fail/all.T new file mode 100644 index 0000000000..f16a2c994b --- /dev/null +++ b/testsuite/tests/qualifieddo/should_fail/all.T @@ -0,0 +1,7 @@ +setTestOpts(only_ways(['normal'])); + +test('qdofail001', normal, compile_fail, ['-v0']) +test('qdofail002', normal, compile_fail, ['-v0']) +test('qdofail003', normal, compile_fail, ['-v0']) +test('qdofail004', normal, compile_fail, ['-v0']) +test('qdofail005', normal, compile_fail, ['-v0']) diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail001.hs b/testsuite/tests/qualifieddo/should_fail/qdofail001.hs new file mode 100644 index 0000000000..1543a72218 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_fail/qdofail001.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE QualifiedDo #-} + +import Prelude as P + + +-- Tests that qualified dos show up in type-checking errors. +main = do + print $ P.do + x <- [1, 2] + y@' ' <- [1, 2 :: Int] + [1, 2] + P.return y diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail001.stderr b/testsuite/tests/qualifieddo/should_fail/qdofail001.stderr new file mode 100644 index 0000000000..62cc54e2df --- /dev/null +++ b/testsuite/tests/qualifieddo/should_fail/qdofail001.stderr @@ -0,0 +1,10 @@ + +qdofail001.hs:11:7: + Couldn't match expected type ‘Int’ with actual type ‘Char’ + In the pattern: ' ' + In a stmt of a qualified 'do' block: y@' ' <- [1, 2 :: Int] + In the second argument of ‘($)’, namely + ‘P.do x <- [1, 2] + y@' ' <- [1, 2 :: Int] + [1, 2] + return y’ diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail002.hs b/testsuite/tests/qualifieddo/should_fail/qdofail002.hs new file mode 100644 index 0000000000..38d3bfc816 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_fail/qdofail002.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE RecursiveDo #-} +import Prelude as P + + +-- Tests that the compiler suggests using -XQualifiedDo +-- when the user qualifies a do. +main = do + print $ P.do + x <- [1, 2] + P.return x + print 1 $ P.mdo + x <- [1, 2] + P.return x diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail002.stderr b/testsuite/tests/qualifieddo/should_fail/qdofail002.stderr new file mode 100644 index 0000000000..5948678eb8 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_fail/qdofail002.stderr @@ -0,0 +1,8 @@ + +qdofail002.hs:8:11: + Illegal qualified ‘P.do’ block + Perhaps you intended to use QualifiedDo + +qdofail002.hs:11:13: + Illegal qualified ‘P.mdo’ block + Perhaps you intended to use QualifiedDo diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail003.hs b/testsuite/tests/qualifieddo/should_fail/qdofail003.hs new file mode 100644 index 0000000000..17cf6af64c --- /dev/null +++ b/testsuite/tests/qualifieddo/should_fail/qdofail003.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE QualifiedDo #-} + +import Prelude as P hiding ((>>)) + + +-- Tests that an out-of-scope (>>) is reported +main = do + print $ P.do + x <- [1, 2] + y <- [1, 2] + [1, 2] + P.return (x, y) diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail003.stderr b/testsuite/tests/qualifieddo/should_fail/qdofail003.stderr new file mode 100644 index 0000000000..5137ae40c0 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_fail/qdofail003.stderr @@ -0,0 +1,8 @@ + +qdofail003.hs:11:5: + Not in scope: ‘P.>>’ + Perhaps you meant one of these: + ‘P.*>’ (imported from Prelude), ‘P.<>’ (imported from Prelude), + ‘P.>>=’ (imported from Prelude) + Perhaps you want to remove ‘>>’ from the explicit hiding list + in the import of ‘Prelude’ (qdofail003.hs:3:1-33). diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail004.hs b/testsuite/tests/qualifieddo/should_fail/qdofail004.hs new file mode 100644 index 0000000000..caba6e0e6b --- /dev/null +++ b/testsuite/tests/qualifieddo/should_fail/qdofail004.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE QualifiedDo #-} + +import Prelude as P hiding (fail) + + +-- Tests that fail is required with refutable patterns +main = do + print $ P.do + x <- [1, 2] + (1, y) <- [(1, "a"), (2, "b")] + P.return (x, y) diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail004.stderr b/testsuite/tests/qualifieddo/should_fail/qdofail004.stderr new file mode 100644 index 0000000000..66a3fea529 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_fail/qdofail004.stderr @@ -0,0 +1,8 @@ + +qdofail004.hs:10:5: + Not in scope: ‘P.fail’ + Perhaps you meant one of these: + ‘P.tail’ (imported from Prelude), ‘P.all’ (imported from Prelude), + ‘P.flip’ (imported from Prelude) + Perhaps you want to remove ‘fail’ from the explicit hiding list + in the import of ‘Prelude’ (qdofail004.hs:3:1-33). diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail005.hs b/testsuite/tests/qualifieddo/should_fail/qdofail005.hs new file mode 100644 index 0000000000..8fc08e1a24 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_fail/qdofail005.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE QualifiedDo #-} + +import Control.Arrow +import Prelude as P + +main = runKleisli kleisliIO 1 + +-- Tests the error message when a qualified do +-- is used in a command. +kleisliIO = proc x -> P.do + y <- arr id -< x+1 + Kleisli print -< 2*y + let z = x+y + t <- arr id -< x*z + returnA -< t+z diff --git a/testsuite/tests/qualifieddo/should_fail/qdofail005.stderr b/testsuite/tests/qualifieddo/should_fail/qdofail005.stderr new file mode 100644 index 0000000000..8d49e1d3ba --- /dev/null +++ b/testsuite/tests/qualifieddo/should_fail/qdofail005.stderr @@ -0,0 +1,5 @@ + +qdofail005.hs:11:23: + Parse error in command: + Found a qualified P.do block in a command, but + qualified 'do' is not supported in commands. diff --git a/testsuite/tests/qualifieddo/should_run/Makefile b/testsuite/tests/qualifieddo/should_run/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/qualifieddo/should_run/Monad/Graded.hs b/testsuite/tests/qualifieddo/should_run/Monad/Graded.hs new file mode 100644 index 0000000000..78f7f30b57 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/Monad/Graded.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +module Monad.Graded where + +import Data.Kind (Constraint, Type) +import Prelude (const, id) + +class GradedMonad (m :: k -> Type -> Type) where + type Unit m :: k + type Plus m (i :: k) (j :: k) :: k + type Inv m (i :: k) (j :: k) :: Constraint + (>>=) :: Inv m i j => m i a -> (a -> m j b) -> m (Plus m i j) b + return :: a -> m (Unit m) a + +(>>) :: (GradedMonad m, Inv m i j) => m i a -> m j b -> m (Plus m i j) b +m >> n = m >>= const n + +join :: (GradedMonad m, Inv m i j) => m i (m j a) -> m (Plus m i j) a +join m = m >>= id diff --git a/testsuite/tests/qualifieddo/should_run/Monad/Linear.hs b/testsuite/tests/qualifieddo/should_run/Monad/Linear.hs new file mode 100644 index 0000000000..df7f2775c8 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/Monad/Linear.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LinearTypes #-} +module Monad.Linear where + +import Prelude(Int, (+)) + +data T where T :: Int -> T +data TM a = TM a + +class Monad m where + return :: a #-> m a + (>>=) :: m a #-> (a #-> m b) #-> m b + +(>>) :: Monad m => m () #-> m b #-> m b +m1 >> m2 = m1 >>= \() -> m2 + +instance Monad TM where + return = TM + TM a >>= f = f a + +data Unrestricted a where + Unrestricted :: a -> Unrestricted a + +runTM :: TM (Unrestricted a) -> a +runTM (TM (Unrestricted a)) = a + +newT :: TM T +newT = return (T 0) + +increaseT :: T #-> TM T +increaseT (T i) = return (T (i+1)) + +extractT :: T #-> TM (T, Unrestricted Int) +extractT (T i) = return (T i, Unrestricted i) + +deleteT :: T #-> TM () +deleteT (T _) = return () diff --git a/testsuite/tests/qualifieddo/should_run/Vector.hs b/testsuite/tests/qualifieddo/should_run/Vector.hs new file mode 100644 index 0000000000..e1cc49e44d --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/Vector.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Vector + ( Vector(..) + , toList + , vAppend + -- exported for QualifiedDo + , fmap + , (<*>) + , pure + , fail + , mfix + ) where + +import Data.Function (fix) +import Data.Maybe (fromMaybe) +import Monad.Graded +import Prelude hiding ((>>=), fail, pure, return, (<*>)) + + +data Nat = Zero | Succ Nat + +data Vector n a where + VNil :: Vector Zero a + VCons :: a -> Vector n a -> Vector (Succ n) a + +instance Functor (Vector n) where + fmap f = \case + VNil -> VNil + VCons a v -> VCons (f a) (fmap f v) + +vAppend :: Vector m a -> Vector n a -> Vector (Add m n) a +vAppend VNil v = v +vAppend (VCons a u) v = VCons a (vAppend u v) + +toList :: Vector n a -> [a] +toList = \case + VNil -> [] + VCons a v -> a : toList v + +fail :: String -> Vector n a +fail = error + +class VRepeat n where + vRepeat :: a -> Vector n a +instance VRepeat Zero where + vRepeat _ = VNil +instance VRepeat n => VRepeat (Succ n) where + vRepeat a = VCons a (vRepeat a) + +type family Add m n :: Nat where + Add Zero n = n + Add (Succ m) n = Succ (Add m n) + +type family Times m n :: Nat where + Times Zero n = Zero + Times (Succ m) n = Add n (Times m n) + +instance GradedMonad Vector where + type Unit Vector = Succ Zero + type Plus Vector i j = Times i j + type Inv Vector i j = () + v >>= f = case v of + VNil -> VNil + VCons a v -> vAppend (f a) (v >>= f) + return a = VCons a VNil + +vHead :: Vector (Succ n) a -> a +vHead (VCons a _) = a + +vTail :: Vector (Succ n) a -> Vector n a +vTail (VCons _ v) = v + +mfix :: forall a n. Show a => (a -> Vector n a) -> Vector n a +mfix f = case fix (f . unsafeHead) of + VNil -> VNil + VCons x _ -> VCons x (mfix (vTail . f)) + where + unsafeHead :: Vector n a -> a + unsafeHead = \case + VNil -> error "VNil" + VCons a _ -> a + +pure :: a -> Vector (Succ Zero) a +pure = return + +(<*>) :: Vector m (a -> b) -> Vector n a -> Vector (Times m n) b +VNil <*> _ = VNil +VCons _ v <*> VNil = v <*> VNil +VCons f vf <*> v = vAppend (fmap f v) (vf <*> v) diff --git a/testsuite/tests/qualifieddo/should_run/all.T b/testsuite/tests/qualifieddo/should_run/all.T new file mode 100644 index 0000000000..17cf2f0d7b --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/all.T @@ -0,0 +1,11 @@ +setTestOpts(only_ways(['normal'])); + +qextra_files = extra_files(['Vector.hs', 'Monad']) + +test('qdorun001', [qextra_files], multimod_compile_and_run, ['qdorun001', '']) +test('qdorun002', [qextra_files], multimod_compile_and_run, ['qdorun002', '']) +test('qdorun003', [qextra_files], multimod_compile_and_run, ['qdorun003', '']) +test('qdorun004', normal, compile_and_run, ['']) +test('qdorun005', [qextra_files], multimod_compile_and_run, ['qdorun005', '']) +test('qdorun006', [qextra_files], multimod_compile_and_run, ['qdorun006', '']) +test('qdorun007', [qextra_files], multimod_compile_and_run, ['qdorun007', '']) diff --git a/testsuite/tests/qualifieddo/should_run/qdorun001.hs b/testsuite/tests/qualifieddo/should_run/qdorun001.hs new file mode 100644 index 0000000000..5c81d2babf --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/qdorun001.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE QualifiedDo #-} + +import qualified Monad.Graded as Graded +import Vector as Graded + + +main = do + putStrLn "The unqualified do still works." + print $ toList $ Graded.do + x <- VCons 1 (VCons 2 VNil) + y <- VCons 1 (VCons 2 VNil) + Graded.return (x, y) + -- test Graded.fail + print $ toList $ Graded.do + 1 <- VCons 1 VNil + Graded.return 1 diff --git a/testsuite/tests/qualifieddo/should_run/qdorun001.stdout b/testsuite/tests/qualifieddo/should_run/qdorun001.stdout new file mode 100644 index 0000000000..a604b4a395 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/qdorun001.stdout @@ -0,0 +1,3 @@ +The unqualified do still works. +[(1,1),(1,2),(2,1),(2,2)] +[1] diff --git a/testsuite/tests/qualifieddo/should_run/qdorun002.hs b/testsuite/tests/qualifieddo/should_run/qdorun002.hs new file mode 100644 index 0000000000..31010310d1 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/qdorun002.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE RecursiveDo #-} + +import qualified Monad.Graded as Graded +import Vector as Graded + + +main = do + print $ take 6 $ concat $ toList $ Graded.do + rec + VCons (take 6 y) VNil + y <- VCons (1 : zipWith (+) y (0 : y)) VNil + Graded.return y diff --git a/testsuite/tests/qualifieddo/should_run/qdorun002.stdout b/testsuite/tests/qualifieddo/should_run/qdorun002.stdout new file mode 100644 index 0000000000..01d885946e --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/qdorun002.stdout @@ -0,0 +1 @@ +[1,1,2,3,5,8] diff --git a/testsuite/tests/qualifieddo/should_run/qdorun003.hs b/testsuite/tests/qualifieddo/should_run/qdorun003.hs new file mode 100644 index 0000000000..a155139514 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/qdorun003.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE QualifiedDo #-} + +import qualified Monad.Graded as Graded +import Vector as Graded + + +main = do + print $ toList $ Graded.do + x <- VCons 1 (VCons 2 VNil) + y <- VCons 1 (VCons 2 VNil) + Graded.return (x, y) + -- Test Graded.join + print $ toList $ Graded.do + x <- VCons 1 (VCons 2 VNil) + y <- VCons 1 (VCons 2 VNil) + VCons (y, x) VNil diff --git a/testsuite/tests/qualifieddo/should_run/qdorun003.stdout b/testsuite/tests/qualifieddo/should_run/qdorun003.stdout new file mode 100644 index 0000000000..ba08850cb4 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/qdorun003.stdout @@ -0,0 +1,2 @@ +[(1,1),(1,2),(2,1),(2,2)] +[(1,1),(2,1),(1,2),(2,2)] diff --git a/testsuite/tests/qualifieddo/should_run/qdorun004.hs b/testsuite/tests/qualifieddo/should_run/qdorun004.hs new file mode 100644 index 0000000000..151f44473e --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/qdorun004.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE RecursiveDo #-} +import qualified Control.Monad.Fix as P +import Prelude (print, ($)) +import qualified Prelude as P + +return :: a -> [a] +return x = [x, x] + +-- Tests that QualifiedDo doesn't affect return +main = do + print $ P.do + x <- [1, 2] + return x + print $ P.mdo + x <- [1, 2] + return x diff --git a/testsuite/tests/qualifieddo/should_run/qdorun004.stdout b/testsuite/tests/qualifieddo/should_run/qdorun004.stdout new file mode 100644 index 0000000000..d7d00ba1c3 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/qdorun004.stdout @@ -0,0 +1,2 @@ +[1,1,2,2] +[1,1,2,2] diff --git a/testsuite/tests/qualifieddo/should_run/qdorun005.hs b/testsuite/tests/qualifieddo/should_run/qdorun005.hs new file mode 100644 index 0000000000..52ecae76fa --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/qdorun005.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE RebindableSyntax #-} +import qualified Monad.Graded as Graded +import Vector +import Prelude (print, ($)) +import qualified Prelude as P + +xs >>= f = 'c' : P.concatMap f xs +(>>) = (P.>>) + +main = do + print $ toList $ Graded.do + x <- VCons 'a' (VCons 'b' VNil) + Graded.return x + print $ do + a <- ['a', 'b'] + P.return a diff --git a/testsuite/tests/qualifieddo/should_run/qdorun005.stdout b/testsuite/tests/qualifieddo/should_run/qdorun005.stdout new file mode 100644 index 0000000000..f7f72c9098 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/qdorun005.stdout @@ -0,0 +1,2 @@ +"ab" +"cab" diff --git a/testsuite/tests/qualifieddo/should_run/qdorun006.hs b/testsuite/tests/qualifieddo/should_run/qdorun006.hs new file mode 100644 index 0000000000..a795b0d251 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/qdorun006.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TemplateHaskell #-} + +import qualified Monad.Graded as Graded +import Vector as Graded + + +main = do + print $ toList $([| Graded.do + x <- VCons 1 (VCons 2 VNil) + y <- VCons 1 (VCons 2 VNil) + Graded.return (x, y) |]) + print $ toList $([| Graded.mdo + z <- VCons (take 8 y) VNil + y <- VCons (1 : zipWith (+) y (0 : y)) VNil + Graded.return z |]) diff --git a/testsuite/tests/qualifieddo/should_run/qdorun006.stdout b/testsuite/tests/qualifieddo/should_run/qdorun006.stdout new file mode 100644 index 0000000000..0280d625f8 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/qdorun006.stdout @@ -0,0 +1,2 @@ +[(1,1),(1,2),(2,1),(2,2)] +[[1,1,2,3,5,8,13,21]] diff --git a/testsuite/tests/qualifieddo/should_run/qdorun007.hs b/testsuite/tests/qualifieddo/should_run/qdorun007.hs new file mode 100644 index 0000000000..189c045e58 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/qdorun007.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE QualifiedDo #-} +-- Tests that QualfiedDo works for a linear monad. + +import Monad.Linear as Linear + + +main = do + let r = runTM (Linear.do + t0 <- newT + t1 <- increaseT t0 + (t2, ur) <- extractT t1 + deleteT t2 + Linear.return ur) + print r + print r diff --git a/testsuite/tests/qualifieddo/should_run/qdorun007.stdout b/testsuite/tests/qualifieddo/should_run/qdorun007.stdout new file mode 100644 index 0000000000..6ed281c757 --- /dev/null +++ b/testsuite/tests/qualifieddo/should_run/qdorun007.stdout @@ -0,0 +1,2 @@ +1 +1 diff --git a/testsuite/tests/th/T2597b_Lib.hs b/testsuite/tests/th/T2597b_Lib.hs index 395166b0b6..bed83fc5bf 100644 --- a/testsuite/tests/th/T2597b_Lib.hs +++ b/testsuite/tests/th/T2597b_Lib.hs @@ -6,4 +6,4 @@ import Language.Haskell.TH mkBug2 :: ExpQ -mkBug2 = return $ DoE [] +mkBug2 = return $ DoE Nothing [] diff --git a/testsuite/tests/th/T9022.hs b/testsuite/tests/th/T9022.hs index fc61691da1..9c676aa7d0 100644 --- a/testsuite/tests/th/T9022.hs +++ b/testsuite/tests/th/T9022.hs @@ -10,7 +10,7 @@ foo = barD barD = FunD ( mkName "bar" ) [ Clause manyArgs (NormalB barBody) [] ] - barBody = DoE [letxStmt, retxStmt] + barBody = DoE Nothing [letxStmt, retxStmt] letxStmt = LetS [ ValD (VarP xName) (NormalB $ LitE $ IntegerL 5) [] ] retxStmt = NoBindS $ AppE returnVarE xVarE xName = mkName "x" diff --git a/utils/haddock b/utils/haddock -Subproject 45add0d8a39172d17e822b762508685d7b43363 +Subproject 54ed6ae2556dc787916e2d56ce0e99808af14e6 |