[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:21:16 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/3c785e4e/attachment-0001.html>


More information about the ghc-commits mailing list