Commit 19f12557 authored by Josef Svenningsson's avatar Josef Svenningsson Committed by Ben Gamari

Fix ApplicativeDo regression #17835

A previous fix for #15344 made sure that monadic 'fail' is used properly
when translating ApplicativeDo. However, it didn't properly account
for when a 'fail' will be inserted which resulted in some programs
failing with a type error.
parent abc02b40
Pipeline #17039 failed with stages
in 422 minutes and 4 seconds
......@@ -2274,22 +2274,31 @@ pprStmt (ApplicativeStmt _ args mb_join)
(if lengthAtLeast args 2 then parens else id) ap_expr
pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc
pp_arg (_, ApplicativeArgOne _ pat expr isBody _)
| isBody = -- See Note [Applicative BodyStmt]
ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
pp_arg (_, applicativeArg) = ppr applicativeArg
pprStmt (XStmtLR x) = ppr x
instance (OutputableBndrId idL)
=> Outputable (ApplicativeArg (GhcPass idL)) where
ppr = pprArg
pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc
pprArg (ApplicativeArgOne _ pat expr isBody _)
| isBody = -- See Note [Applicative BodyStmt]
ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
:: ExprStmt (GhcPass idL))
| otherwise =
ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
| otherwise =
ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
:: ExprStmt (GhcPass idL))
pp_arg (_, ApplicativeArgMany _ stmts return pat) =
pprArg (ApplicativeArgMany _ stmts return pat) =
ppr pat <+>
text "<-" <+>
ppr (HsDo (panic "pprStmt") DoExpr (noLoc
(stmts ++
[noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)])))
pp_arg (_, XApplicativeArg x) = ppr x
pprStmt (XStmtLR x) = ppr x
pprArg (XApplicativeArg x) = ppr x
pprTransformStmt :: (OutputableBndrId p)
=> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
......
......@@ -1498,7 +1498,7 @@ ApplicativeDo touches a few phases in the compiler:
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
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.
......@@ -1682,7 +1682,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ fail_op
, is_body_stmt = False
, fail_operator = fail_op}]
False tail'
stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ fail_op),_))
stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))
tail _tail_fvs
| (False,tail') <- needJoin monad_names tail
= mkApplicativeStmt ctxt
......@@ -1691,7 +1691,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ fail_op),_)
, app_arg_pattern = nlWildPatName
, arg_expr = rhs
, is_body_stmt = True
, fail_operator = fail_op}] False tail'
, fail_operator = noSyntaxExpr}] False tail'
stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
return (s : tail, emptyNameSet)
......@@ -1706,7 +1706,8 @@ 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') =
if any hasStrictPattern trees
-- See Note [ApplicativeDo and refutable patterns]
if any hasRefutablePattern stmts'
then (True, tail)
else needJoin monad_names tail
......@@ -1721,13 +1722,13 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
, is_body_stmt = False
, fail_operator = fail_op
}, emptyFVs)
stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ fail_op), _)) =
stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =
return (ApplicativeArgOne
{ xarg_app_arg_one = noExtField
, app_arg_pattern = nlWildPatName
, arg_expr = exp
, is_body_stmt = True
, fail_operator = fail_op
, fail_operator = noSyntaxExpr
}, emptyFVs)
stmtTreeArg ctxt tail_fvs tree = do
let stmts = flattenStmtTree tree
......@@ -1854,12 +1855,19 @@ 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
{-
Note [ApplicativeDo and refutable patterns]
Refutable patterns in do blocks are desugared to use the monadic 'fail' operation.
This means that sometimes an applicative block needs to be wrapped in 'join' simply because
of a refutable pattern, in order for the types to work out.
-}
hasRefutablePattern :: ApplicativeArg GhcRn -> Bool
hasRefutablePattern (ApplicativeArgOne { app_arg_pattern = pat
, is_body_stmt = False}) = not (isIrrefutableHsPat pat)
hasRefutablePattern _ = False
isLetStmt :: LStmt a b -> Bool
isLetStmt (L _ LetStmt{}) = True
......
......@@ -32,10 +32,15 @@ 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 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)
-- Build.hs
{-# LANGUAGE ApplicativeDo #-}
module Build (configRules) where
type Action = IO
type Rules = IO
type Config = ()
(%>) :: String -> (String -> Action ()) -> Rules ()
(%>) = undefined
command_ :: [String] -> String -> [String] -> Action ()
command_ = undefined
recursive :: Config -> String -> [String] -> IO (FilePath, [String])
recursive = undefined
liftIO :: IO a -> Action a
liftIO = id
need :: [String] -> Action ()
need = undefined
historyDisable :: Action ()
historyDisable = undefined
get_config :: () -> Action Config
get_config = undefined
configRules :: Rules ()
configRules = do
"snapshot" %> \out -> do
historyDisable -- 8.10-rc1 refuses to compile without bind here
config <- get_config ()
need []
(exe,args) <- liftIO $ recursive config "snapshot" []
command_ [] exe args
......@@ -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)
......@@ -17,3 +17,4 @@ test('T13875', normal, compile_and_run, [''])
test('T14163', normal, compile_and_run, [''])
test('T15344', normal, compile_and_run, [''])
test('T16628', normal, compile_fail, [''])
test('T17835', normal, compile, [''])
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