[Git][ghc/ghc][master] 2 commits: Fix #16518 with some more kind-splitting smarts
Ben Gamari
gitlab at gitlab.haskell.org
Thu Apr 4 19:15:14 UTC 2019
Ben Gamari pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
25c02ea1 by Ryan Scott at 2019-04-04T08:29:29Z
Fix #16518 with some more kind-splitting smarts
This patch corrects two simple oversights that led to #16518:
1. `HsUtils.typeToLHsType` was taking visibility into account in the
`TyConApp` case, but not the `AppTy` case. I've factored out the
visibility-related logic into its own `go_app` function and now
invoke `go_app` from both the `TyConApp` and `AppTy` cases.
2. `Type.fun_kind_arg_flags` did not properly split kinds with
nested `forall`s, such as
`(forall k. k -> Type) -> (forall k. k -> Type)`. This was simply
because `fun_kind_arg_flags`'s `FunTy` case always bailed out and
assumed all subsequent arguments were `Required`, which clearly
isn't the case for nested `forall`s. I tweaked the `FunTy` case
to recur on the result kind.
- - - - -
51fd3571 by Ryan Scott at 2019-04-04T08:35:39Z
Use funPrec, not topPrec, to parenthesize GADT argument types
A simple oversight. Fixes #16527.
- - - - -
9 changed files:
- compiler/hsSyn/HsUtils.hs
- compiler/iface/IfaceSyn.hs
- compiler/types/Type.hs
- + testsuite/tests/deriving/should_compile/T16518.hs
- testsuite/tests/deriving/should_compile/all.T
- + testsuite/tests/ghci/scripts/T16527.hs
- + testsuite/tests/ghci/scripts/T16527.script
- + testsuite/tests/ghci/scripts/T16527.stdout
- testsuite/tests/ghci/scripts/all.T
Changes:
=====================================
compiler/hsSyn/HsUtils.hs
=====================================
@@ -106,7 +106,7 @@ import TcEvidence
import RdrName
import Var
import TyCoRep
-import Type ( tyConArgFlags )
+import Type ( appTyArgFlags, splitAppTys, tyConArgFlags )
import TysWiredIn ( unitTy )
import TcType
import DataCon
@@ -665,7 +665,6 @@ typeToLHsType ty
, hst_xforall = noExt
, hst_body = go tau })
go (TyVarTy tv) = nlHsTyVar (getRdrName tv)
- go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2)
go (LitTy (NumTyLit n))
= noLoc $ HsTyLit NoExt (HsNumTy NoSourceText n)
go (LitTy (StrTyLit s))
@@ -674,27 +673,35 @@ typeToLHsType ty
| tyConAppNeedsKindSig True tc (length args)
-- We must produce an explicit kind signature here to make certain
-- programs kind-check. See Note [Kind signatures in typeToLHsType].
- = nlHsParTy $ noLoc $ HsKindSig NoExt lhs_ty (go (tcTypeKind ty))
- | otherwise = lhs_ty
+ = nlHsParTy $ noLoc $ HsKindSig NoExt ty' (go (tcTypeKind ty))
+ | otherwise = ty'
where
- arg_flags :: [ArgFlag]
- arg_flags = tyConArgFlags tc args
-
- lhs_ty :: LHsType GhcPs
- lhs_ty = foldl' (\f (arg, flag) ->
- let arg' = go arg in
- case flag of
- Inferred -> f
- Specified -> f `nlHsAppKindTy` arg'
- Required -> f `nlHsAppTy` arg')
- (nlHsTyVar (getRdrName tc))
- (zip args arg_flags)
+ ty' :: LHsType GhcPs
+ ty' = go_app (nlHsTyVar (getRdrName tc)) args (tyConArgFlags tc args)
+ go ty@(AppTy {}) = go_app (go head) args (appTyArgFlags head args)
+ where
+ head :: Type
+ args :: [Type]
+ (head, args) = splitAppTys ty
go (CastTy ty _) = go ty
go (CoercionTy co) = pprPanic "toLHsSigWcType" (ppr co)
-- Source-language types have _invisible_ kind arguments,
-- so we must remove them here (#8563)
+ go_app :: LHsType GhcPs -- The type being applied
+ -> [Type] -- The argument types
+ -> [ArgFlag] -- The argument types' visibilities
+ -> LHsType GhcPs
+ go_app head args arg_flags =
+ foldl' (\f (arg, flag) ->
+ let arg' = go arg in
+ case flag of
+ Inferred -> f
+ Specified -> f `nlHsAppKindTy` arg'
+ Required -> f `nlHsAppTy` arg')
+ head (zip args arg_flags)
+
go_tv :: TyVar -> LHsTyVarBndr GhcPs
go_tv tv = noLoc $ KindedTyVar noExt (noLoc (getRdrName tv))
(go (tyVarKind tv))
=====================================
compiler/iface/IfaceSyn.hs
=====================================
@@ -1034,7 +1034,7 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent
-- a compound field type is if it's preceded by a bang pattern.
pprFieldArgTy (bang, ty) = ppr_arg_ty (bang_prec bang) bang ty
-- If not using record syntax, a compound field type might need to be
- -- parenthesize if one of the following holds:
+ -- parenthesized if one of the following holds:
--
-- 1. We're using Haskell98 syntax.
-- 2. The field type is preceded with a bang pattern.
@@ -1046,18 +1046,23 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent
-- If we're displaying the fields GADT-style, e.g.,
--
-- data Foo a where
- -- MkFoo :: Maybe a -> Foo
+ -- MkFoo :: (Int -> Int) -> Maybe a -> Foo
--
- -- Then there is no inherent need to parenthesize compound fields like
- -- `Maybe a` (bang patterns notwithstanding). If we're displaying the
- -- fields Haskell98-style, e.g.,
+ -- Then we use `funPrec`, since that will ensure `Int -> Int` gets the
+ -- parentheses that it requires, but simple compound types like `Maybe a`
+ -- (which don't require parentheses in a function argument position) won't
+ -- get them, assuming that there are no bang patterns (see bang_prec).
--
- -- data Foo a = MkFoo (Maybe a)
+ -- If we're displaying the fields Haskell98-style, e.g.,
--
- -- Then we *must* parenthesize compound fields like (Maybe a).
+ -- data Foo a = MkFoo (Int -> Int) (Maybe a)
+ --
+ -- Then not only must we parenthesize `Int -> Int`, we must also
+ -- parenthesize compound fields like (Maybe a). Therefore, we pick
+ -- `appPrec`, which has higher precedence than `funPrec`.
gadt_prec :: PprPrec
gadt_prec
- | gadt_style = topPrec
+ | gadt_style = funPrec
| otherwise = appPrec
-- The presence of bang patterns or UNPACK annotations requires
=====================================
compiler/types/Type.hs
=====================================
@@ -1698,6 +1698,21 @@ fun_kind_arg_flags = go emptyTCvSubst
subst' = extendTvSubst subst tv arg_ty
go subst (TyVarTy tv) arg_tys
| Just ki <- lookupTyVar subst tv = go subst ki arg_tys
+ -- This FunTy case is important to handle kinds with nested foralls, such
+ -- as this kind (inspired by #16518):
+ --
+ -- forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type
+ --
+ -- Here, we want to get the following ArgFlags:
+ --
+ -- [Inferred, Specified, Required, Required, Specified, Required]
+ -- forall {k1}. forall k2. k1 -> k2 -> forall k3. k3 -> Type
+ go subst (FunTy{ft_af = af, ft_res = res_ki}) (_:arg_tys)
+ = argf : go subst res_ki arg_tys
+ where
+ argf = case af of
+ VisArg -> Required
+ InvisArg -> Inferred
go _ _ arg_tys = map (const Required) arg_tys
-- something is ill-kinded. But this can happen
-- when printing errors. Assume everything is Required.
=====================================
testsuite/tests/deriving/should_compile/T16518.hs
=====================================
@@ -0,0 +1,36 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+module T16518 where
+
+import Data.Coerce
+import Data.Kind
+import Data.Type.Equality
+
+-----
+
+class HTestEquality1 (f :: forall k. k -> Type) where
+ hTestEquality1 :: forall k1 k2 (a :: k1) (b :: k2).
+ f a -> f b -> Maybe (a :~~: b)
+newtype T1 :: (forall k. k -> Type) -> (forall k. k -> Type) where
+ MkT1 :: forall (f :: forall k. k -> Type) k (a :: k). f a -> T1 f a
+
+deriving instance forall (f :: forall k. k -> Type).
+ HTestEquality1 f => HTestEquality1 (T1 f)
+
+-----
+
+class HTestEquality2 (f :: forall k -> k -> Type) where
+ hTestEquality2 :: forall k1 k2 (a :: k1) (b :: k2).
+ f k1 a -> f k2 b -> Maybe (a :~~: b)
+newtype T2 :: (forall k -> k -> Type) -> (forall k -> k -> Type) where
+ MkT2 :: forall (f :: forall k -> k -> Type) k (a :: k). f k a -> T2 f k a
+
+deriving instance forall (f :: forall k -> k -> Type).
+ HTestEquality2 f => HTestEquality2 (T2 f)
=====================================
testsuite/tests/deriving/should_compile/all.T
=====================================
@@ -115,3 +115,4 @@ test('T15290d', normal, compile, [''])
test('T15398', normal, compile, [''])
test('T15637', normal, compile, [''])
test('T16179', normal, compile, [''])
+test('T16518', normal, compile, [''])
=====================================
testsuite/tests/ghci/scripts/T16527.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+module T16527 where
+
+data T where
+ MkT1 :: (Int -> Int) -> T
+ MkT2 :: (forall a. Maybe a) -> T
=====================================
testsuite/tests/ghci/scripts/T16527.script
=====================================
@@ -0,0 +1,2 @@
+:load T16527
+:info T
=====================================
testsuite/tests/ghci/scripts/T16527.stdout
=====================================
@@ -0,0 +1,4 @@
+data T where
+ MkT1 :: (Int -> Int) -> T
+ MkT2 :: (forall a. Maybe a) -> T
+ -- Defined at T16527.hs:5:1
=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -294,3 +294,4 @@ test('T11606', normal, ghci_script, ['T11606.script'])
test('T16089', normal, ghci_script, ['T16089.script'])
test('T14828', normal, ghci_script, ['T14828.script'])
test('T16376', normal, ghci_script, ['T16376.script'])
+test('T16527', normal, ghci_script, ['T16527.script'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/75abaaead796415cf2b5da610f4b3ee75b9d7759...51fd357119b357c52e990ccce9059c423cc49406
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/75abaaead796415cf2b5da610f4b3ee75b9d7759...51fd357119b357c52e990ccce9059c423cc49406
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/20190404/763d93d9/attachment-0001.html>
More information about the ghc-commits
mailing list