Fix #16030 by refactoring IfaceSyn's treatment of GADT constructors

Summary:
GHCi's `:info` command was pretty-printined GADT
constructors suboptimally in the following ways:

1. Sometimes, fields were parenthesized when they did not need it,
   e.g.,

```lang=haskell
data Foo a where
  MkFoo :: (Maybe a) -> Foo a
```

   I fixed this by refactoring some code in `pprIfaceConDecl` to be a
   little smarter with respect to GADT syntax. See `pprFieldArgTy`
   and `pprArgTy`.
2. With `-fprint-explicit-kinds` enabled, there would be times when
   specified arguments would be printed without a leading `@` in GADT
   return types, e.g.,

```lang=haskell
data Bar @k (a :: k) where
  MkBar :: Bar k a
```

   It turns out that `ppr_tc_app`, the function which pretty-prints
   these return types, was not using the proper machinery to print
   out the arguments, which caused the visibilities to be forgotten
   entirely. I refactored `ppr_tc_app` to do this correctly.

Test Plan: make test TEST=T16030

Reviewers: goldfire, bgamari, simonpj

Reviewed By: simonpj

Subscribers: simonpj, rwbarton, carter

GHC Trac Issues: #16030

Differential Revision: https://phabricator.haskell.org/D5440

6 files changed, 114 insertions, 31 deletions

diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 1bf4ca9c81..5478c941c0 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -65,7 +65,7 @@ import Fingerprint
 import Binary
 import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue )
 import Var( VarBndr(..), binderVar )
-import TyCon ( Role (..), Injectivity(..) )
+import TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag )
 import Util( dropList, filterByList )
 import DataCon (SrcStrictness(..), SrcUnpackedness(..))
 import Lexeme (isLexSym)
@@ -1029,30 +1029,59 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent
     ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <>
                                pprParendIfaceCoercion co
 
-    pprParendBangTy (bang, ty) = ppr_bang bang <> pprParendIfaceType ty
-    pprBangTy       (bang, ty) = ppr_bang bang <> ppr_banged_ty ty
-      where
-        -- The presence of bang patterns or UNPACK annotations requires
-        -- surrounding the type with parentheses, if needed (#13699)
-        ppr_banged_ty = case bang of
-                          IfNoBang     -> ppr
-                          IfStrict     -> pprParendIfaceType
-                          IfUnpack     -> pprParendIfaceType
-                          IfUnpackCo{} -> pprParendIfaceType
-
-    pp_args :: [SDoc]  -- With parens, e.g  (Maybe a)  or  !(Maybe a)
-    pp_args = map pprParendBangTy tys_w_strs
-
-    pp_field_args :: SDoc  -- Braces form:  { x :: !Maybe a, y :: Int }
+    pprFieldArgTy, pprArgTy :: (IfaceBang, IfaceType) -> SDoc
+    -- If using record syntax, the only reason one would need to parenthesize
+    -- 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:
+    --
+    -- 1. We're using Haskell98 syntax.
+    -- 2. The field type is preceded with a bang pattern.
+    pprArgTy (bang, ty) = ppr_arg_ty (max gadt_prec (bang_prec bang)) bang ty
+
+    ppr_arg_ty :: PprPrec -> IfaceBang -> IfaceType -> SDoc
+    ppr_arg_ty prec bang ty = ppr_bang bang <> pprPrecIfaceType prec ty
+
+    -- If we're displaying the fields GADT-style, e.g.,
+    --
+    --   data Foo a where
+    --     MkFoo :: 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.,
+    --
+    --   data Foo a = MkFoo (Maybe a)
+    --
+    -- Then we *must* parenthesize compound fields like (Maybe a).
+    gadt_prec :: PprPrec
+    gadt_prec
+      | gadt_style = topPrec
+      | otherwise  = appPrec
+
+    -- The presence of bang patterns or UNPACK annotations requires
+    -- surrounding the type with parentheses, if needed (#13699)
+    bang_prec :: IfaceBang -> PprPrec
+    bang_prec IfNoBang     = topPrec
+    bang_prec IfStrict     = appPrec
+    bang_prec IfUnpack     = appPrec
+    bang_prec IfUnpackCo{} = appPrec
+
+    pp_args :: [SDoc] -- No records, e.g., `  Maybe a  ->  Int -> ...` or
+                      --                   `!(Maybe a) -> !Int -> ...`
+    pp_args = map pprArgTy tys_w_strs
+
+    pp_field_args :: SDoc -- Records, e.g., { x ::   Maybe a,  y ::  Int } or
+                          --                { x :: !(Maybe a), y :: !Int }
     pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $
                     zipWith maybe_show_label fields tys_w_strs
 
     maybe_show_label :: FieldLabel -> (IfaceBang, IfaceType) -> Maybe SDoc
     maybe_show_label lbl bty
-      | showSub ss sel =
-          Just (pprPrefixIfDeclBndr how_much occ <+> dcolon <+> pprBangTy bty)
-      | otherwise      =
-          Nothing
+      | showSub ss sel = Just (pprPrefixIfDeclBndr how_much occ
+                                <+> dcolon <+> pprFieldArgTy bty)
+      | otherwise      = Nothing
       where
         sel = flSelector lbl
         occ = mkVarOccFS (flLabel lbl)
@@ -1063,19 +1092,31 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent
       | IfDataInstance _ tc tys <- parent
       = pprIfaceType (IfaceTyConApp tc (substIfaceAppArgs gadt_subst tys))
       | otherwise
-      = sdocWithDynFlags (ppr_tc_app gadt_subst)
+      = ppr_tc_app gadt_subst
       where
         gadt_subst = mkIfaceTySubst eq_spec
 
-    ppr_tc_app gadt_subst dflags
-       = pprPrefixIfDeclBndr how_much (occName tycon)
-         <+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv)
-                 | IfaceTvBndr (tv,_kind)
-                   -- Coercions variables are invisible, see Note
-                   -- [VarBndrs, TyCoVarBinders, TyConBinders, and visibility]
-                   -- in TyCoRep
-                     <- map (ifTyConBinderVar) $
-                        suppressIfaceInvisibles dflags tc_binders tc_binders ]
+    -- When pretty-printing a GADT return type, we:
+    --
+    -- 1. Take the data tycon binders, extract their variable names and
+    --    visibilities, and construct suitable arguments from them. (This is
+    --    the role of mk_tc_app_args.)
+    -- 2. Apply the GADT substitution constructed from the eq_spec.
+    --    (See Note [Result type of a data family GADT].)
+    -- 3. Pretty-print the data type constructor applied to its arguments.
+    --    This process will omit any invisible arguments, such as coercion
+    --    variables, if necessary. (See Note
+    --    [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.)
+    ppr_tc_app gadt_subst =
+      pprPrefixIfDeclBndr how_much (occName tycon)
+      <+> pprIfaceAppArgs
+            (substIfaceAppArgs gadt_subst (mk_tc_app_args tc_binders))
+
+    mk_tc_app_args :: [IfaceTyConBinder] -> IfaceAppArgs
+    mk_tc_app_args [] = IA_Nil
+    mk_tc_app_args (Bndr bndr vis:tc_bndrs) =
+      IA_Arg (IfaceTyVar (ifaceBndrName bndr)) (tyConBndrVisArgFlag vis)
+             (mk_tc_app_args tc_bndrs)
 
 instance Outputable IfaceRule where
   ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs
index c92c5d00f5..ebbc68755b 100644
--- a/compiler/iface/IfaceType.hs
+++ b/compiler/iface/IfaceType.hs
@@ -24,7 +24,7 @@ module IfaceType (
         IfaceForAllBndr, ArgFlag(..), ShowForAllFlag(..),
         mkIfaceForAllTvBndr,
 
-        ifForAllBndrVar, ifForAllBndrName,
+        ifForAllBndrVar, ifForAllBndrName, ifaceBndrName,
         ifTyConBinderVar, ifTyConBinderName,
 
         -- Equality testing
diff --git a/testsuite/tests/ghci/scripts/T16030.hs b/testsuite/tests/ghci/scripts/T16030.hs
new file mode 100644
index 0000000000..159c017b06
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T16030.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module T16030 where
+
+import Data.Proxy
+
+data Foo1 (a :: k) where
+  MkFoo1a :: Proxy a -> Int -> Foo1 a
+  MkFoo1b :: { a :: Proxy a, b :: Int } -> Foo1 a
+
+data family Foo2 (a :: k)
+data instance Foo2 (a :: k) where
+  MkFoo2a :: Proxy a -> Int -> Foo2 a
+  MkFoo2b :: { c :: Proxy a, d :: Int } -> Foo2 a
diff --git a/testsuite/tests/ghci/scripts/T16030.script b/testsuite/tests/ghci/scripts/T16030.script
new file mode 100644
index 0000000000..20a119297e
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T16030.script
@@ -0,0 +1,4 @@
+:load T16030
+:info Foo1 Foo2
+:set -fprint-explicit-kinds
+:info Foo1 Foo2
diff --git a/testsuite/tests/ghci/scripts/T16030.stdout b/testsuite/tests/ghci/scripts/T16030.stdout
new file mode 100644
index 0000000000..d1691a6758
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T16030.stdout
@@ -0,0 +1,22 @@
+type role Foo1 phantom
+data Foo1 (a :: k) where
+  MkFoo1a :: forall k (a :: k). Proxy a -> Int -> Foo1 a
+  MkFoo1b :: forall k (a :: k). {a :: Proxy a, b :: Int} -> Foo1 a
+  	-- Defined at T16030.hs:8:1
+data family Foo2 (a :: k) 	-- Defined at T16030.hs:12:1
+data instance forall k (a :: k). Foo2 a where
+  MkFoo2a :: forall k (a :: k). Proxy a -> Int -> Foo2 a
+  MkFoo2b :: forall k (a :: k). {c :: Proxy a, d :: Int} -> Foo2 a
+  	-- Defined at T16030.hs:13:15
+type role Foo1 nominal phantom
+data Foo1 @k (a :: k) where
+  MkFoo1a :: forall k (a :: k). Proxy @{k} a -> Int -> Foo1 @k a
+  MkFoo1b :: forall k (a :: k).
+             {a :: Proxy @{k} a, b :: Int} -> Foo1 @k a
+  	-- Defined at T16030.hs:8:1
+data family Foo2 @k (a :: k) 	-- Defined at T16030.hs:12:1
+data instance forall k (a :: k). Foo2 @k a where
+  MkFoo2a :: forall k (a :: k). Proxy @{k} a -> Int -> Foo2 @k a
+  MkFoo2b :: forall k (a :: k).
+             {c :: Proxy @{k} a, d :: Int} -> Foo2 @k a
+  	-- Defined at T16030.hs:13:15
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 13753cd3ec..ad4a24f583 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -292,3 +292,4 @@ test('T15743b', normal, ghci_script, ['T15743b.script'])
 test('T15827', normal, ghci_script, ['T15827.script'])
 test('T15898', normal, ghci_script, ['T15898.script'])
 test('T15941', normal, ghci_script, ['T15941.script'])
+test('T16030', normal, ghci_script, ['T16030.script'])