[Git][ghc/ghc][wip/tyconapp-opts] 6 commits: Fix ApplicativeDo regression #17835
Ben Gamari
gitlab at gitlab.haskell.org
Wed Mar 25 20:06:16 UTC 2020
Ben Gamari pushed to branch wip/tyconapp-opts 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.
- - - - -
2643ba46 by Paavo at 2020-03-24T08:31:32-04:00
Add example and doc for Arg (Fixes #17153)
- - - - -
3a83b452 by Ben Gamari at 2020-03-24T15:58:11-04:00
Notes from call
- - - - -
e6e4d941 by Ben Gamari at 2020-03-24T15:58:11-04:00
Comparing nullary type synonyms
- - - - -
735c6450 by Ben Gamari at 2020-03-24T15:58:11-04:00
Fixes
- - - - -
667fe314 by Ben Gamari at 2020-03-24T15:58:11-04:00
Move logic into tYPE
- - - - -
13 changed files:
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Rename/Expr.hs
- compiler/prelude/TysPrim.hs
- compiler/prelude/TysWiredIn.hs
- compiler/typecheck/TcCanonical.hs
- compiler/typecheck/TcType.hs
- libraries/base/Data/Semigroup.hs
- testsuite/tests/ado/T13242a.stderr
- + testsuite/tests/ado/T17835.hs
- testsuite/tests/ado/ado001.stdout
- testsuite/tests/ado/all.T
Changes:
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -243,7 +243,7 @@ import GHC.Core.TyCon
import TysPrim
import {-# SOURCE #-} TysWiredIn ( listTyCon, typeNatKind
, typeSymbolKind, liftedTypeKind
- , liftedTypeKindTyCon
+ , liftedTypeKindTyCon, liftedRepDataConTy
, constraintKind )
import Name( Name )
import PrelNames
@@ -1231,6 +1231,7 @@ compilation. In order to avoid a potentially expensive series of checks in
-- its arguments. Applies its arguments to the constructor from left to right.
mkTyConApp :: TyCon -> [Type] -> Type
mkTyConApp tycon tys
+-- TODO: TYPE 'LiftedRep
| isFunTyCon tycon
, [_rep1,_rep2,ty1,ty2] <- tys
-- The FunTyCon (->) is always a visible one
@@ -1239,6 +1240,10 @@ mkTyConApp tycon tys
| tycon == liftedTypeKindTyCon
= ASSERT2( null tys, ppr tycon $$ ppr tys )
liftedTypeKindTyConApp
+ -- Note [mkTyConApp and Type]
+ | tycon == tYPETyCon
+ , [rep] <- tys
+ = tYPE rep
| otherwise
= TyConApp tycon tys
@@ -2266,6 +2271,7 @@ data TypeOrdering = TLT -- ^ @t1 < t2@
| TGT -- ^ @t1 > t2@
deriving (Eq, Ord, Enum, Bounded)
+-- TODO: nullary synonym optimization
nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse
-- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep
nonDetCmpTypeX env orig_t1 orig_t2 =
@@ -2301,6 +2307,10 @@ nonDetCmpTypeX env orig_t1 orig_t2 =
-- Returns both the resulting ordering relation between the two types
-- and whether either contains a cast.
go :: RnEnv2 -> Type -> Type -> TypeOrdering
+ -- See Note [Comparing nullary type synonyms].
+ go _ (TyConApp tc1 []) (TyConApp tc2 [])
+ | tc1 == tc2
+ = TEQ
go env t1 t2
| Just t1' <- coreView t1 = go env t1' t2
| Just t2' <- coreView t2 = go env t1 t2'
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -957,6 +957,11 @@ unify_ty :: UMEnv
-- Respects newtypes, PredTypes
unify_ty env ty1 ty2 kco
+ -- See Note [Comparing nullary type synonyms].
+ | TyConApp tc1 [] <- ty1
+ , TyConApp tc2 [] <- ty2
+ , tc1 == tc2 = return ()
+
-- TODO: More commentary needed here
| Just ty1' <- tcView ty1 = unify_ty env ty1' ty2 kco
| Just ty2' <- tcView ty2 = unify_ty env ty1 ty2' kco
=====================================
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
=====================================
compiler/prelude/TysPrim.hs
=====================================
@@ -527,6 +527,9 @@ mkPrimTcName built_in_syntax occ key tycon
-- | Given a RuntimeRep, applies TYPE to it.
-- see Note [TYPE and RuntimeRep]
tYPE :: Type -> Type
+ -- static cases
+tYPE (TyConApp tc [])
+ | tc `hasKey` liftedRepDataConKey = liftedTypeKind -- TYPE 'LiftedPtrRep
tYPE rr = TyConApp tYPETyCon [rr]
{-
=====================================
compiler/prelude/TysWiredIn.hs
=====================================
@@ -145,6 +145,7 @@ import Id
import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )
import Module ( Module )
import GHC.Core.Type
+import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp))
import GHC.Types.RepType
import GHC.Core.DataCon
import {-# SOURCE #-} GHC.Core.ConLike
@@ -642,7 +643,7 @@ constraintKindTyCon :: TyCon
constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] []
liftedTypeKind, typeToTypeKind, constraintKind :: Kind
-liftedTypeKind = tYPE liftedRepTy
+liftedTypeKind = TyCoRep.TyConApp liftedTypeKindTyCon []
typeToTypeKind = liftedTypeKind `mkVisFunTy` liftedTypeKind
constraintKind = mkTyConApp constraintKindTyCon []
=====================================
compiler/typecheck/TcCanonical.hs
=====================================
@@ -969,8 +969,14 @@ can_eq_nc'
-> Type -> Type -- RHS, after and before type-synonym expansion, resp
-> TcS (StopOrContinue Ct)
+-- See Note [Comparing nullary type synonyms].
+can_eq_nc' _flat _rdr_env _envs ev _eq_rel ty1@(TyConApp tc1 []) _ps_ty1 (TyConApp tc2 []) _ps_ty2
+ | tc1 == tc2
+ = canEqReflexive ev ReprEq ty1
+
-- Expand synonyms first; see Note [Type synonyms and canonicalization]
can_eq_nc' flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
+-- TODO: Handle nullary synonyms
| Just ty1' <- tcView ty1 = can_eq_nc' flat rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2
| Just ty2' <- tcView ty2 = can_eq_nc' flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2' ps_ty2
=====================================
compiler/typecheck/TcType.hs
=====================================
@@ -1533,6 +1533,11 @@ tc_eq_type keep_syns vis_only orig_ty1 orig_ty2
= go orig_env orig_ty1 orig_ty2
where
go :: RnEnv2 -> Type -> Type -> Bool
+ -- See Note [Comparing nullary type synonyms].
+ go _ (TyConApp tc1 []) (TyConApp tc2 [])
+ | tc1 == tc2
+ = True
+
go env t1 t2 | not keep_syns, Just t1' <- tcView t1 = go env t1' t2
go env t1 t2 | not keep_syns, Just t2' <- tcView t2 = go env t1 t2'
@@ -1565,6 +1570,7 @@ tc_eq_type keep_syns vis_only orig_ty1 orig_ty2
= go env s1 s2 && go env t1 t2
go env (TyConApp tc1 ts1) (TyConApp tc2 ts2)
+ -- TODO: nullary synonym optimisation
= tc1 == tc2 && gos env (tc_vis tc1) ts1 ts2
go env (CastTy t1 _) t2 = go env t1 t2
=====================================
libraries/base/Data/Semigroup.hs
=====================================
@@ -286,7 +286,15 @@ instance Num a => Num (Max a) where
-- | 'Arg' isn't itself a 'Semigroup' in its own right, but it can be
-- placed inside 'Min' and 'Max' to compute an arg min or arg max.
-data Arg a b = Arg a b deriving
+--
+-- >>> minimum [ Arg (x * x) x | x <- [-10 .. 10] ]
+-- Arg 0 0
+data Arg a b = Arg
+ a
+ -- ^ The argument used for comparisons in 'Eq' and 'Ord'.
+ b
+ -- ^ The "value" exposed via the 'Functor', 'Foldable' etc. instances.
+ deriving
( Show -- ^ @since 4.9.0.0
, Read -- ^ @since 4.9.0.0
, Data -- ^ @since 4.9.0.0
=====================================
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/-/compare/c7546de3736a0b925d9e6273f7cf9598c2fc75c9...667fe3140c90d9437a389787476fbbbe3bb2903b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c7546de3736a0b925d9e6273f7cf9598c2fc75c9...667fe3140c90d9437a389787476fbbbe3bb2903b
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/20200325/0ae472fe/attachment-0001.html>
More information about the ghc-commits
mailing list