diff options
| -rw-r--r-- | compiler/GHC/Hs/Expr.hs | 35 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Utils.hs | 8 | ||||
| -rw-r--r-- | compiler/deSugar/Coverage.hs | 3 | ||||
| -rw-r--r-- | compiler/deSugar/DsExpr.hs | 26 | ||||
| -rw-r--r-- | compiler/hieFile/HieAst.hs | 2 | ||||
| -rw-r--r-- | compiler/rename/RnExpr.hs | 97 | ||||
| -rw-r--r-- | compiler/typecheck/TcHsSyn.hs | 14 | ||||
| -rw-r--r-- | compiler/typecheck/TcMatches.hs | 30 | ||||
| -rw-r--r-- | testsuite/tests/ado/T13242a.stderr | 11 | ||||
| -rw-r--r-- | testsuite/tests/ado/T15344.hs | 10 | ||||
| -rw-r--r-- | testsuite/tests/ado/T15344.stdout | 1 | ||||
| -rw-r--r-- | testsuite/tests/ado/T16628.hs | 14 | ||||
| -rw-r--r-- | testsuite/tests/ado/T16628.stderr | 15 | ||||
| -rw-r--r-- | testsuite/tests/ado/ado001.stdout | 2 | ||||
| -rw-r--r-- | testsuite/tests/ado/ado008.hs | 187 | ||||
| -rw-r--r-- | testsuite/tests/ado/all.T | 3 |
16 files changed, 390 insertions, 68 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index a3ad2bcada..91c532d2d9 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -1906,18 +1906,27 @@ type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon -- | Applicative Argument data ApplicativeArg idL = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) - (XApplicativeArgOne idL) - (LPat idL) -- WildPat if it was a BodyStmt (see below) - (LHsExpr idL) - Bool -- True <=> was a BodyStmt - -- False <=> was a BindStmt - -- See Note [Applicative BodyStmt] - + { xarg_app_arg_one :: (XApplicativeArgOne idL) + , app_arg_pattern :: (LPat idL) -- WildPat if it was a BodyStmt (see below) + , arg_expr :: (LHsExpr idL) + , is_body_stmt :: Bool -- True <=> was a BodyStmt + -- False <=> was a BindStmt + -- See Note [Applicative BodyStmt] + , fail_operator :: (SyntaxExpr idL) -- The fail operator + -- The fail operator is needed if this is a BindStmt + -- where the pattern can fail. E.g.: + -- (Just a) <- stmt + -- The fail operator will be invoked if the pattern + -- match fails. + -- The fail operator is noSyntaxExpr + -- if the pattern match can't fail + } | ApplicativeArgMany -- do { stmts; return vars } - (XApplicativeArgMany idL) - [ExprLStmt idL] -- stmts - (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn) - (LPat idL) -- (v1,...,vn) + { xarg_app_arg_many :: (XApplicativeArgMany idL) + , app_stmts :: [ExprLStmt idL] -- stmts + , final_expr :: (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn) + , bv_pattern :: (LPat idL) -- (v1,...,vn) + } | XApplicativeArg (XXApplicativeArg idL) type instance XApplicativeArgOne (GhcPass _) = NoExtField @@ -2144,7 +2153,7 @@ pprStmt (ApplicativeStmt _ args mb_join) flattenStmt stmt = [ppr stmt] flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc] - flattenArg (_, ApplicativeArgOne _ pat expr isBody) + flattenArg (_, ApplicativeArgOne _ pat expr isBody _) | isBody = -- See Note [Applicative BodyStmt] [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr :: ExprStmt (GhcPass idL))] @@ -2164,7 +2173,7 @@ pprStmt (ApplicativeStmt _ args mb_join) else text "join" <+> parens ap_expr pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc - pp_arg (_, ApplicativeArgOne _ pat expr isBody) + pp_arg (_, ApplicativeArgOne _ pat expr isBody _) | isBody = -- See Note [Applicative BodyStmt] ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr :: ExprStmt (GhcPass idL)) diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 5d54196af2..0126cd0bac 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -1040,8 +1040,8 @@ collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmt collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args where - collectArgBinders (_, ApplicativeArgOne _ pat _ _) = collectPatBinders pat - collectArgBinders (_, ApplicativeArgMany _ _ _ pat) = collectPatBinders pat + collectArgBinders (_, ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat + collectArgBinders (_, ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat collectArgBinders _ = [] collectStmtBinders (XStmtLR nec) = noExtCon nec @@ -1344,8 +1344,8 @@ lStmtsImplicits = hs_lstmts -> [(SrcSpan, [Name])] hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args - where do_arg (_, ApplicativeArgOne _ pat _ _) = lPatImplicits pat - do_arg (_, ApplicativeArgMany _ stmts _ _) = hs_lstmts stmts + where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat + do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts do_arg (_, XApplicativeArg nec) = noExtCon nec hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds) hs_stmt (BodyStmt {}) = [] diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 6138c26ec2..6dd6d37a9a 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -769,11 +769,12 @@ addTickApplicativeArg addTickApplicativeArg isGuard (op, arg) = liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) where - addTickArg (ApplicativeArgOne x pat expr isBody) = + addTickArg (ApplicativeArgOne x pat expr isBody fail) = (ApplicativeArgOne x) <$> addTickLPat pat <*> addTickLHsExpr expr <*> pure isBody + <*> addTickSyntaxExpr hpcSrcSpan fail addTickArg (ApplicativeArgMany x stmts ret pat) = (ApplicativeArgMany x) <$> addTickLStmts isGuard stmts diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 8d6ddf03e1..cfb799e05f 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -37,7 +37,6 @@ import GHC.Hs import TcType import TcEvidence import TcRnMonad -import TcHsSyn import Type import CoreSyn import CoreUtils @@ -924,25 +923,26 @@ dsDo stmts let (pats, rhss) = unzip (map (do_arg . snd) args) - do_arg (ApplicativeArgOne _ pat expr _) = - (pat, dsLExpr expr) + do_arg (ApplicativeArgOne _ pat expr _ fail_op) = + ((pat, fail_op), dsLExpr expr) do_arg (ApplicativeArgMany _ stmts ret pat) = - (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)])) + ((pat, noSyntaxExpr), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)])) do_arg (XApplicativeArg nec) = noExtCon nec - arg_tys = map hsPatType pats - ; rhss' <- sequence rhss - ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts) + ; body' <- dsLExpr $ noLoc $ HsDo body_ty DoExpr (noLoc stmts) - ; let fun = cL noSrcSpan $ HsLam noExtField $ - MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats - body'] - , mg_ext = MatchGroupTc arg_tys body_ty - , mg_origin = Generated } + ; let match_args (pat, fail_op) (vs,body) + = do { var <- selectSimpleMatchVarL pat + ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat + body_ty (cantFailMatchResult body) + ; match_code <- handle_failure pat match fail_op + ; return (var:vs, match_code) + } - ; fun' <- dsLExpr fun + ; (vars, body) <- foldrM match_args ([],body') pats + ; let fun' = mkLams vars body ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r] ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss') ; case mb_join of diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs index 52f8c59a4d..ca91056e06 100644 --- a/compiler/hieFile/HieAst.hs +++ b/compiler/hieFile/HieAst.hs @@ -1177,7 +1177,7 @@ instance ( a ~ GhcPass p , Data (StmtLR a a (Located (HsExpr a))) , Data (HsLocalBinds a) ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where - toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM + toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM [ toHie $ PS Nothing sc NoScope pat , toHie expr ] diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 42d38c23e9..d3f72fff47 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -1492,12 +1492,45 @@ dsDo {(arg_1 | ... | arg_n); stmts} expr = <*> ... <*> argexpr(arg_n) += Relevant modules in the rest of the compiler = + +ApplicativeDo touches a few phases in the compiler: + +* Renamer: The journey begins here in the renamer, where do-blocks are + scheduled as outlined above and transformed into applicative + combinators. However, the code is still represented as a do-block + with special forms of applicative statements. This allows us to + recover the original do-block when e.g. printing type errors, where + we don't want to show any of the applicative combinators since they + don't exist in the source code. + See ApplicativeStmt and ApplicativeArg in HsExpr. + +* Typechecker: ApplicativeDo passes through the typechecker much like any + other form of expression. The only crux is that the typechecker has to + be aware of the special ApplicativeDo statements in the do-notation, and + typecheck them appropriately. + Relevant module: TcMatches + +* Desugarer: Any do-block which contains applicative statements is desugared + as outlined above, to use the Applicative combinators. + Relevant module: DsExpr + -} -- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and -- 'pureName' due to @RebindableSyntax@. data MonadNames = MonadNames { return_name, pure_name :: Name } +instance Outputable MonadNames where + ppr (MonadNames {return_name=return_name,pure_name=pure_name}) = + hcat + [text "MonadNames { return_name = " + ,ppr return_name + ,text ", pure_name = " + ,ppr pure_name + ,text "}" + ] + -- | rearrange a list of statements using ApplicativeDoStmt. See -- Note [ApplicativeDo]. rearrangeForApplicativeDo @@ -1640,16 +1673,27 @@ stmtTreeToStmts -- In the spec, but we do it here rather than in the desugarer, -- because we need the typechecker to typecheck the <$> form rather than -- the bind form, which would give rise to a Monad constraint. -stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ _), _)) +stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ fail_op), _)) tail _tail_fvs | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail -- See Note [ApplicativeDo and strict patterns] - = mkApplicativeStmt ctxt [ApplicativeArgOne noExtField pat rhs False] False tail' -stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_)) + = mkApplicativeStmt ctxt [ApplicativeArgOne + { xarg_app_arg_one = noExtField + , app_arg_pattern = pat + , arg_expr = rhs + , is_body_stmt = False + , fail_operator = fail_op}] + False tail' +stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ fail_op),_)) tail _tail_fvs | (False,tail') <- needJoin monad_names tail = mkApplicativeStmt ctxt - [ApplicativeArgOne noExtField nlWildPatName rhs True] False tail' + [ApplicativeArgOne + { xarg_app_arg_one = noExtField + , app_arg_pattern = nlWildPatName + , arg_expr = rhs + , is_body_stmt = True + , fail_operator = fail_op}] False tail' stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs = return (s : tail, emptyNameSet) @@ -1663,14 +1707,30 @@ stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees let (stmts', fvss) = unzip pairs - let (need_join, tail') = needJoin monad_names tail + let (need_join, tail') = + if any hasStrictPattern trees + then (True, tail) + else needJoin monad_names tail + (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail' return (stmts, unionNameSets (fvs:fvss)) where - stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ _), _)) - = return (ApplicativeArgOne noExtField pat exp False, emptyFVs) - stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) = - return (ApplicativeArgOne noExtField nlWildPatName exp True, emptyFVs) + stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ fail_op), _)) + = return (ApplicativeArgOne + { xarg_app_arg_one = noExtField + , app_arg_pattern = pat + , arg_expr = exp + , is_body_stmt = False + , fail_operator = fail_op + }, emptyFVs) + stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ fail_op), _)) = + return (ApplicativeArgOne + { xarg_app_arg_one = noExtField + , app_arg_pattern = nlWildPatName + , arg_expr = exp + , is_body_stmt = True + , fail_operator = fail_op + }, emptyFVs) stmtTreeArg ctxt tail_fvs tree = do let stmts = flattenStmtTree tree pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) @@ -1684,9 +1744,15 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do if | L _ ApplicativeStmt{} <- last stmts' -> return (unLoc tup, emptyNameSet) | otherwise -> do - (ret,fvs) <- lookupStmtNamePoly ctxt returnMName - return (HsApp noExtField (noLoc ret) tup, fvs) - return ( ApplicativeArgMany noExtField stmts' mb_ret pat + ret <- lookupSyntaxName' returnMName + let expr = HsApp noExtField (noLoc (HsVar noExtField (noLoc ret))) tup + return (expr, emptyFVs) + return ( ApplicativeArgMany + { xarg_app_arg_many = noExtField + , app_stmts = stmts' + , final_expr = mb_ret + , bv_pattern = pat + } , fvs1 `plusFV` fvs2) @@ -1790,6 +1856,13 @@ isStrictPattern lpat = SplicePat{} -> True _otherwise -> panic "isStrictPattern" +hasStrictPattern :: ExprStmtTree -> Bool +hasStrictPattern (StmtTreeOne (L _ (BindStmt _ pat _ _ _), _)) = isStrictPattern pat +hasStrictPattern (StmtTreeOne _) = False +hasStrictPattern (StmtTreeBind a b) = hasStrictPattern a || hasStrictPattern b +hasStrictPattern (StmtTreeApplicative trees) = any hasStrictPattern trees + + isLetStmt :: LStmt a b -> Bool isLetStmt (L _ LetStmt{}) = True isLetStmt _ = False diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 8ae3a8dc18..744af979b1 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -1260,17 +1260,18 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join) = do { (env1, new_mb_join) <- zonk_join env mb_join ; (env2, new_args) <- zonk_args env1 args ; new_body_ty <- zonkTcTypeToTypeX env2 body_ty - ; return (env2, ApplicativeStmt new_body_ty new_args new_mb_join) } + ; return ( env2 + , ApplicativeStmt new_body_ty new_args new_mb_join) } where zonk_join env Nothing = return (env, Nothing) zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j - get_pat (_, ApplicativeArgOne _ pat _ _) = pat + get_pat (_, ApplicativeArgOne _ pat _ _ _) = pat get_pat (_, ApplicativeArgMany _ _ _ pat) = pat get_pat (_, XApplicativeArg nec) = noExtCon nec - replace_pat pat (op, ApplicativeArgOne x _ a isBody) - = (op, ApplicativeArgOne x pat a isBody) + replace_pat pat (op, ApplicativeArgOne x _ a isBody fail_op) + = (op, ApplicativeArgOne x pat a isBody fail_op) replace_pat pat (op, ApplicativeArgMany x a b _) = (op, ApplicativeArgMany x a b pat) replace_pat _ (_, XApplicativeArg nec) = noExtCon nec @@ -1290,9 +1291,10 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join) ; return (env2, (new_op, new_arg) : new_args) } zonk_args_rev env [] = return (env, []) - zonk_arg env (ApplicativeArgOne x pat expr isBody) + zonk_arg env (ApplicativeArgOne x pat expr isBody fail_op) = do { new_expr <- zonkLExpr env expr - ; return (ApplicativeArgOne x pat new_expr isBody) } + ; (_, new_fail) <- zonkSyntaxExpr env fail_op + ; return (ApplicativeArgOne x pat new_expr isBody new_fail) } zonk_arg env (ApplicativeArgMany x stmts ret pat) = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts ; new_ret <- zonkExpr env1 ret diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index 139f729fea..82985ecf84 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -12,6 +12,7 @@ TcMatches: Typecheck some @Matches@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda, TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker, @@ -991,7 +992,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside -- Typecheck each ApplicativeArg separately -- See Note [ApplicativeDo and constraints] - ; args' <- mapM goArg (zip3 args pat_tys exp_tys) + ; args' <- mapM (goArg body_ty) (zip3 args pat_tys exp_tys) -- Bring into scope all the things bound by the args, -- and typecheck the thing_inside @@ -1011,18 +1012,30 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside ; ops' <- goOps t_i ops ; return (op' : ops') } - goArg :: (ApplicativeArg GhcRn, Type, Type) + goArg :: Type -> (ApplicativeArg GhcRn, Type, Type) -> TcM (ApplicativeArg GhcTcId) - goArg (ApplicativeArgOne x pat rhs isBody, pat_ty, exp_ty) + goArg body_ty (ApplicativeArgOne + { app_arg_pattern = pat + , arg_expr = rhs + , fail_operator = fail_op + , .. + }, pat_ty, exp_ty) = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $ addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs)) $ do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty) ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ return () - ; return (ApplicativeArgOne x pat' rhs' isBody) } + ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op body_ty - goArg (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty) + ; return (ApplicativeArgOne + { app_arg_pattern = pat' + , arg_expr = rhs' + , fail_operator = fail_op' + , .. } + ) } + + goArg _body_ty (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty) = do { (stmts', (ret',pat')) <- tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $ \res_ty -> do @@ -1033,14 +1046,13 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside } ; return (ApplicativeArgMany x stmts' ret' pat') } - goArg (XApplicativeArg nec, _, _) = noExtCon nec + goArg _body_ty (XApplicativeArg nec, _, _) = noExtCon nec get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id] - get_arg_bndrs (ApplicativeArgOne _ pat _ _) = collectPatBinders pat - get_arg_bndrs (ApplicativeArgMany _ _ _ pat) = collectPatBinders pat + get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat + get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat get_arg_bndrs (XApplicativeArg nec) = noExtCon nec - {- Note [ApplicativeDo and constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ An applicative-do is supposed to take place in parallel, so diff --git a/testsuite/tests/ado/T13242a.stderr b/testsuite/tests/ado/T13242a.stderr index f31307df50..22804add1c 100644 --- a/testsuite/tests/ado/T13242a.stderr +++ b/testsuite/tests/ado/T13242a.stderr @@ -11,7 +11,7 @@ T13242a.hs:10:5: error: _ <- return 'a' _ <- return 'b' return (x == x) - In an equation for ‘test’: + • In an equation for ‘test’: test = do A x <- undefined _ <- return 'a' @@ -32,15 +32,10 @@ T13242a.hs:13:11: error: ...plus 21 others ...plus six instances involving out-of-scope types (use -fprint-potential-instances to see them all) - • In a stmt of a 'do' block: return (x == x) + • In the first argument of ‘return’, namely ‘(x == x)’ + In a stmt of a 'do' block: return (x == x) In the expression: do A x <- undefined _ <- return 'a' _ <- return 'b' return (x == x) - In an equation for ‘test’: - test - = do A x <- undefined - _ <- return 'a' - _ <- return 'b' - return (x == x) diff --git a/testsuite/tests/ado/T15344.hs b/testsuite/tests/ado/T15344.hs new file mode 100644 index 0000000000..3956423ef6 --- /dev/null +++ b/testsuite/tests/ado/T15344.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ApplicativeDo #-} + +f :: Maybe (Maybe Int) -> Maybe Int -> Maybe Int +f mgs mid = do + _ <- mid + (Just moi) <- mgs + pure (moi + 42) + +main :: IO () +main = print (f (Just Nothing) (Just 2)) diff --git a/testsuite/tests/ado/T15344.stdout b/testsuite/tests/ado/T15344.stdout new file mode 100644 index 0000000000..4a584e4989 --- /dev/null +++ b/testsuite/tests/ado/T15344.stdout @@ -0,0 +1 @@ +Nothing diff --git a/testsuite/tests/ado/T16628.hs b/testsuite/tests/ado/T16628.hs new file mode 100644 index 0000000000..8508c19e7f --- /dev/null +++ b/testsuite/tests/ado/T16628.hs @@ -0,0 +1,14 @@ +-- Bug.hs +{-# LANGUAGE ApplicativeDo #-} +module Main where + +import Data.Functor.Identity + +f :: Identity () -> Identity [Int] -> Identity Int +f i0 i1 = do + _ <- i0 + [x] <- i1 + pure (x + 42) + +main :: IO () +main = print $ f (Identity ()) (Identity []) diff --git a/testsuite/tests/ado/T16628.stderr b/testsuite/tests/ado/T16628.stderr new file mode 100644 index 0000000000..6ea95f1754 --- /dev/null +++ b/testsuite/tests/ado/T16628.stderr @@ -0,0 +1,15 @@ + +T16628.hs:10:5: + No instance for (MonadFail Identity) + arising from a do statement + with the failable pattern ‘[x]’ + In a stmt of a 'do' block: [x] <- i1 + In the expression: + do _ <- i0 + [x] <- i1 + pure (x + 42) + In an equation for ‘f’: + f i0 i1 + = do _ <- i0 + [x] <- i1 + pure (x + 42) diff --git a/testsuite/tests/ado/ado001.stdout b/testsuite/tests/ado/ado001.stdout index 365860f55e..6f56cceaa0 100644 --- a/testsuite/tests/ado/ado001.stdout +++ b/testsuite/tests/ado/ado001.stdout @@ -9,4 +9,4 @@ a; ((b | c) | d) ((a | (b; c)) | d) | e ((a | b); (c | d)) | e a | b -a | (b; c) +(a | (b; c)) diff --git a/testsuite/tests/ado/ado008.hs b/testsuite/tests/ado/ado008.hs new file mode 100644 index 0000000000..b72930496f --- /dev/null +++ b/testsuite/tests/ado/ado008.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, ApplicativeDo, + RebindableSyntax #-} +{- This module is mostly a copy of ado001 but tests that all those + functions work when we have RebindableSyntax enabled +-} +module Main where + +import Prelude hiding (return, (>>=), pure, (<*>), fmap) +import Text.PrettyPrint as PP + +(a:b:c:d:e:f:g:h:_) = map (\c -> doc [c]) ['a'..] + +-- a | b +test1 :: M () +test1 = do + x1 <- a + x2 <- b + const (return ()) (x1,x2) + +-- no parallelism +test2 :: M () +test2 = do + x1 <- a + x2 <- const g x1 + const (return ()) (x1,x2) + +-- a | (b;g) | e +test3 :: M () +test3 = do + x1 <- a + x2 <- b + x3 <- const g x2 + x4 <- e + return () `const` (x1,x2,x3,x4) + +-- (a ; (b | g)) | c +-- or +-- ((a | b); g) | c +test4 :: M () +test4 = do + x1 <- a + x2 <- b + x3 <- const g x1 + x4 <- c + return () `const` (x2,x3,x4) + +-- (a | b | c); (g | h) +test5 :: M () +test5 = do + x1 <- a + x2 <- b + x3 <- c + x4 <- const g x1 + x5 <- const h x3 + return () `const` (x3,x4,x5) + +-- b/c in parallel, e/f in parallel +-- a; (b | (c; (d; (e | (f; g))))) +test6 :: M () +test6 = do + x1 <- a + x2 <- const b x1 + x3 <- const c x1 + x4 <- const d x3 + x5 <- const e x4 + x6 <- const f x4 + x7 <- const g x6 + return () `const` (x1,x2,x3,x4,x5,x6,x7) + +-- (a | b); (c | d) +test7 :: M () +test7 = do + x1 <- a + x2 <- b + x3 <- const c x1 + x4 <- const d x2 + return () `const` (x3,x4) + +-- a; (b | c | d) +-- +-- alternative (but less good): +-- ((a;b) | c); d +test8 :: M () +test8 = do + x1 <- a + x2 <- const b x1 + x3 <- c + x4 <- const d x1 + return () `const` (x2,x3,x4) + +-- test that Lets don't get in the way +-- ((a | (b; c)) | d) | e +test9 :: M () +test9 = do + x1 <- a + let x = doc "x" -- this shouldn't get in the way of grouping a/b + x2 <- b + x3 <- const c x2 + x4 <- d + x5 <- e + let y = doc "y" + return () + +-- ((a | b) ; (c | d)) | e +test10 :: M () +test10 = do + x1 <- a + x2 <- b + let z1 = (x1,x2) + x3 <- const c x1 + let z2 = (x1,x2) + x4 <- const d z1 + x5 <- e + return (const () (x3,x4,x5)) + +-- (a | b) +-- This demonstrated a bug in RnExpr.segments (#11612) +test11 :: M () +test11 = do + x1 <- a + let x2 = x1 + x3 <- b + let x4 = c + x5 = x4 + return (const () (x1,x2,x3,x4)) + +-- (a | (b ; c)) +-- The strict pattern match forces (b;c), but a can still be parallel (#13875) +test12 :: M () +test12 = do + x1 <- a + () <- b + x2 <- c + return (const () (x1,x2)) + +main = mapM_ run + [ test1 + , test2 + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + , test10 + , test11 + , test12 + ] + +-- Testing code, prints out the structure of a monad/applicative expression + +newtype M a = M (Bool -> (Maybe Doc, a)) + +maybeParen True d = parens d +maybeParen _ d = d + +run :: M a -> IO () +run (M m) = print d where (Just d,_) = m False + +fmap f m = m >>= (return . f) + +join :: M (M a) -> M a +join x = x >>= id + +pure a = M $ \_ -> (Nothing, a) + +M f <*> M a = M $ \p -> + let (Just d1, f') = f True + (Just d2, a') = a True + in + (Just (maybeParen p (d1 <+> char '|' <+> d2)), f' a') + +return = pure + +M m >>= k = M $ \p -> + let (d1, a) = m True + (d2, b) = case k a of M f -> f True + in + case (d1,d2) of + (Nothing,Nothing) -> (Nothing, b) + (Just d, Nothing) -> (Just d, b) + (Nothing, Just d) -> (Just d, b) + (Just d1, Just d2) -> (Just (maybeParen p (d1 PP.<> semi <+> d2)), b) + +doc :: String -> M () +doc d = M $ \_ -> (Just (text d), ()) diff --git a/testsuite/tests/ado/all.T b/testsuite/tests/ado/all.T index 866e414da8..634aae2314 100644 --- a/testsuite/tests/ado/all.T +++ b/testsuite/tests/ado/all.T @@ -5,6 +5,7 @@ test('ado004', normalise_version('base','ghc-prim','integer-gmp'), compile, [''] test('ado005', normal, compile_fail, ['']) test('ado006', normal, compile, ['']) test('ado007', normal, compile, ['']) +test('ado008', normal, compile, ['']) test('T11607', normal, compile_and_run, ['']) test('ado-optimal', normal, compile_and_run, ['']) test('T12490', normal, compile, ['']) @@ -12,3 +13,5 @@ test('T13242', normal, compile, ['']) test('T13242a', normal, compile_fail, ['']) test('T13875', normal, compile_and_run, ['']) test('T14163', normal, compile_and_run, ['']) +test('T15344', normal, compile_and_run, ['']) +test('T16628', normal, compile_fail, ['']) |