diff options
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 |