[Git][ghc/ghc][master] Fix ApplicativeDo regression #17835
Marge Bot
gitlab at gitlab.haskell.org
Tue Mar 24 12:31:08 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
19f12557 by Josef Svenningsson at 2020-03-23T14:05:33-04:00
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.
- - - - -
6 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Rename/Expr.hs
- testsuite/tests/ado/T13242a.stderr
- + testsuite/tests/ado/T17835.hs
- testsuite/tests/ado/ado001.stdout
- testsuite/tests/ado/all.T
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -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)
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -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
=====================================
testsuite/tests/ado/T13242a.stderr
=====================================
@@ -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)
=====================================
testsuite/tests/ado/T17835.hs
=====================================
@@ -0,0 +1,38 @@
+-- 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
=====================================
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)
=====================================
testsuite/tests/ado/all.T
=====================================
@@ -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, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/19f125578247dfe8036b5793cb3f6b684474f9c7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/19f125578247dfe8036b5793cb3f6b684474f9c7
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200324/e607158a/attachment-0001.html>
More information about the ghc-commits
mailing list