diff options
author | Ryan Scott <ryan.gl.scott@gmail.com> | 2018-12-19 19:17:58 +0100 |
---|---|---|
committer | Krzysztof Gogolewski <krz.gogolewski@gmail.com> | 2018-12-19 20:57:06 +0100 |
commit | 9d9e35574a92773d872efd58a67339a9e054a9f1 (patch) | |
tree | f5446c48c7096bdb88561670b3175dd03fd65a18 | |
parent | d555d4beb457f485aa122d118903f6f926f054f8 (diff) | |
download | haskell-9d9e35574a92773d872efd58a67339a9e054a9f1.tar.gz |
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
-rw-r--r-- | compiler/iface/IfaceSyn.hs | 101 | ||||
-rw-r--r-- | compiler/iface/IfaceType.hs | 2 | ||||
-rw-r--r-- | testsuite/tests/ghci/scripts/T16030.hs | 15 | ||||
-rw-r--r-- | testsuite/tests/ghci/scripts/T16030.script | 4 | ||||
-rw-r--r-- | testsuite/tests/ghci/scripts/T16030.stdout | 22 | ||||
-rwxr-xr-x | testsuite/tests/ghci/scripts/all.T | 1 |
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']) |