Commit 6635a3f6 authored by josef.svenningsson@gmail.com's avatar josef.svenningsson@gmail.com Committed by Marge Bot

Fix #15344: use fail when desugaring applicative-do

Applicative-do has a bug where it fails to use the monadic fail method
when desugaring patternmatches which can fail. See #15344.

This patch fixes that problem. It required more rewiring than I had expected.
Applicative-do happens mostly in the renamer; that's where decisions about
scheduling are made. This schedule is then carried through the typechecker and
into the desugarer which performs the actual translation. Fixing this bug
required sending information about the fail method from the renamer, through
the type checker and into the desugarer. Previously, the desugarer didn't
have enough information to actually desugar pattern matches correctly.

As a side effect, we also fix #16628, where GHC wouldn't catch missing
MonadFail instances with -XApplicativeDo.
parent 90d06fd0
Pipeline #11909 passed with stages
in 960 minutes and 43 seconds
......@@ -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))
......
......@@ -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 {}) = []
......
......@@ -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
......
......@@ -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
......
......@@ -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
]
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)
{-# 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))
-- 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 [])
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)
......@@ -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))
{-# 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), ())
......@@ -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, [''])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment