Commit 9d9e3557 authored by Ryan Scott's avatar Ryan Scott Committed by Krzysztof Gogolewski

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
parent d555d4be
Pipeline #410 failed with stage
......@@ -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,
......
......@@ -24,7 +24,7 @@ module IfaceType (
IfaceForAllBndr, ArgFlag(..), ShowForAllFlag(..),
mkIfaceForAllTvBndr,
ifForAllBndrVar, ifForAllBndrName,
ifForAllBndrVar, ifForAllBndrName, ifaceBndrName,
ifTyConBinderVar, ifTyConBinderName,
-- Equality testing
......
{-# 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
:load T16030
:info Foo1 Foo2
:set -fprint-explicit-kinds
:info Foo1 Foo2
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
......@@ -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'])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment