[Git][ghc/ghc][master] 2 commits: Do not print synonyms in :i (->), :i Type (#18594)
Marge Bot
gitlab at gitlab.haskell.org
Mon Aug 24 04:31:59 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
8b865092 by Krzysztof Gogolewski at 2020-08-23T14:12:53+02:00
Do not print synonyms in :i (->), :i Type (#18594)
This adds a new printing flag `sdocPrintTypeAbbreviations` that is used
specifically to avoid ghci printing 'type (->) = (->)' and 'type Type = Type'.
- - - - -
d8f61182 by Krzysztof Gogolewski at 2020-08-23T14:12:56+02:00
Move pprTyTcApp' inside pprTyTcApp
No semantic change
- - - - -
11 changed files:
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Utils/Outputable.hs
- testsuite/tests/ghci/T18060/T18060.stdout
- testsuite/tests/ghci/scripts/T8535.stdout
- testsuite/tests/ghci/scripts/ghci020.stdout
- testsuite/tests/ghci/should_run/T10145.stdout
- + testsuite/tests/ghci/should_run/T18594.script
- + testsuite/tests/ghci/should_run/T18594.stdout
- testsuite/tests/ghci/should_run/all.T
Changes:
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -5079,6 +5079,7 @@ initSDocContext dflags style = SDC
, sdocStarIsType = xopt LangExt.StarIsType dflags
, sdocImpredicativeTypes = xopt LangExt.ImpredicativeTypes dflags
, sdocLinearTypes = xopt LangExt.LinearTypes dflags
+ , sdocPrintTypeAbbreviations = True
, sdocDynFlags = dflags
}
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -45,6 +45,8 @@ module GHC.Iface.Syntax (
import GHC.Prelude
+import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey )
+import GHC.Types.Unique ( hasKey )
import GHC.Iface.Type
import GHC.Iface.Recomp.Binary
import GHC.Core( IsOrphan, isOrphan )
@@ -947,13 +949,19 @@ pprIfaceDecl ss (IfaceSynonym { ifName = tc
, ifResKind = res_kind})
= vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind)
, hang (text "type" <+> pprIfaceDeclHead suppress_bndr_sig [] ss tc binders <+> equals)
- 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau
+ 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr_tau
, ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ])
]
where
(tvs, theta, tau) = splitIfaceSigmaTy mono_ty
name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tc)
+ -- See Note [Printing type abbreviations] in GHC.Iface.Type
+ ppr_tau | tc `hasKey` liftedTypeKindTyConKey ||
+ tc `hasKey` unrestrictedFunTyConKey
+ = updSDocContext (\ctx -> ctx { sdocPrintTypeAbbreviations = False }) $ ppr tau
+ | otherwise = ppr tau
+
-- See Note [Suppressing binder signatures] in GHC.Iface.Type
suppress_bndr_sig = SuppressBndrSig True
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -783,6 +783,22 @@ Here we'd like to omit the kind annotation:
type F :: Symbol -> Type
type F s = blah
+
+Note [Printing type abbreviations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Normally, we pretty-print `TYPE 'LiftedRep` as `Type` (or `*`) and
+`FUN 'Many` as `(->)`.
+This way, error messages don't refer to levity polymorphism or linearity
+if it is not necessary.
+
+However, when printing the definition of Type or (->) with :info,
+this would give confusing output: `type (->) = (->)` (#18594).
+Solution: detect when we are in :info and disable displaying the synonym
+with the SDoc option sdocPrintTypeAbbreviations.
+
+If there will be a need, in the future we could expose it as a flag
+-fprint-type-abbreviations or even two separate flags controlling
+TYPE 'LiftedRep and FUN 'Many.
-}
-- | Do we want to suppress kind annotations on binders?
@@ -1364,56 +1380,55 @@ pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args
pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc
pprTyTcApp ctxt_prec tc tys =
sdocOption sdocPrintExplicitKinds $ \print_kinds ->
+ sdocOption sdocPrintTypeAbbreviations $ \print_type_abbreviations ->
getPprDebug $ \debug ->
- pprTyTcApp' ctxt_prec tc tys (PrintExplicitKinds print_kinds) debug
-
-pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceAppArgs
- -> PrintExplicitKinds -> Bool -> SDoc
-pprTyTcApp' ctxt_prec tc tys printExplicitKinds debug
- | ifaceTyConName tc `hasKey` ipClassKey
- , IA_Arg (IfaceLitTy (IfaceStrTyLit n))
- Required (IA_Arg ty Required IA_Nil) <- tys
- = maybeParen ctxt_prec funPrec
- $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty
-
- | IfaceTupleTyCon arity sort <- ifaceTyConSort info
- , not debug
- , arity == ifaceVisAppArgsLength tys
- = pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys
-
- | IfaceSumTyCon arity <- ifaceTyConSort info
- = pprSum arity (ifaceTyConIsPromoted info) tys
-
- | tc `ifaceTyConHasKey` consDataConKey
- , PrintExplicitKinds False <- printExplicitKinds
- , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys
- , isInvisibleArgFlag argf
- = pprIfaceTyList ctxt_prec ty1 ty2
-
- | tc `ifaceTyConHasKey` tYPETyConKey
- , IA_Arg (IfaceTyConApp rep IA_Nil) Required IA_Nil <- tys
- , rep `ifaceTyConHasKey` liftedRepDataConKey
- = ppr_kind_type ctxt_prec
- | tc `ifaceTyConHasKey` funTyConKey
- , IA_Arg (IfaceTyConApp rep IA_Nil) Required args <- tys
- , rep `ifaceTyConHasKey` manyDataConKey
- = pprIfacePrefixApp ctxt_prec (parens arrow) (map (ppr_ty appPrec) (appArgsIfaceTypes $ stripInvisArgs printExplicitKinds args))
-
- | otherwise
- = getPprDebug $ \dbg ->
- if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey
+ if | ifaceTyConName tc `hasKey` ipClassKey
+ , IA_Arg (IfaceLitTy (IfaceStrTyLit n))
+ Required (IA_Arg ty Required IA_Nil) <- tys
+ -> maybeParen ctxt_prec funPrec
+ $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty
+
+ | IfaceTupleTyCon arity sort <- ifaceTyConSort info
+ , not debug
+ , arity == ifaceVisAppArgsLength tys
+ -> pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys
+
+ | IfaceSumTyCon arity <- ifaceTyConSort info
+ -> pprSum arity (ifaceTyConIsPromoted info) tys
+
+ | tc `ifaceTyConHasKey` consDataConKey
+ , False <- print_kinds
+ , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys
+ , isInvisibleArgFlag argf
+ -> pprIfaceTyList ctxt_prec ty1 ty2
+
+ | tc `ifaceTyConHasKey` tYPETyConKey
+ , IA_Arg (IfaceTyConApp rep IA_Nil) Required IA_Nil <- tys
+ , rep `ifaceTyConHasKey` liftedRepDataConKey
+ , print_type_abbreviations -- See Note [Printing type abbreviations]
+ -> ppr_kind_type ctxt_prec
+
+ | tc `ifaceTyConHasKey` funTyConKey
+ , IA_Arg (IfaceTyConApp rep IA_Nil) Required args <- tys
+ , rep `ifaceTyConHasKey` manyDataConKey
+ , print_type_abbreviations -- See Note [Printing type abbreviations]
+ -> pprIfacePrefixApp ctxt_prec (parens arrow) (map (ppr_ty appPrec) $
+ appArgsIfaceTypes $ stripInvisArgs (PrintExplicitKinds print_kinds) args)
+
+ | tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey
+ , not debug
-- Suppress detail unless you _really_ want to see
- -> text "(TypeError ...)"
+ -> text "(TypeError ...)"
| Just doc <- ppr_equality ctxt_prec tc (appArgsIfaceTypes tys)
- -> doc
+ -> doc
| otherwise
- -> ppr_iface_tc_app ppr_app_arg ctxt_prec tc tys_wo_kinds
+ -> ppr_iface_tc_app ppr_app_arg ctxt_prec tc $
+ appArgsIfaceTypesArgFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) tys
where
info = ifaceTyConInfo tc
- tys_wo_kinds = appArgsIfaceTypesArgFlags $ stripInvisArgs printExplicitKinds tys
ppr_kind_type :: PprPrec -> SDoc
ppr_kind_type ctxt_prec = sdocOption sdocStarIsType $ \case
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -344,6 +344,7 @@ data SDocContext = SDC
, sdocStarIsType :: !Bool
, sdocLinearTypes :: !Bool
, sdocImpredicativeTypes :: !Bool
+ , sdocPrintTypeAbbreviations :: !Bool
, sdocDynFlags :: DynFlags -- TODO: remove
}
@@ -390,6 +391,7 @@ defaultSDocContext = SDC
, sdocStarIsType = False
, sdocImpredicativeTypes = False
, sdocLinearTypes = False
+ , sdocPrintTypeAbbreviations = True
, sdocDynFlags = error "defaultSDocContext: DynFlags not available"
}
=====================================
testsuite/tests/ghci/T18060/T18060.stdout
=====================================
@@ -1,5 +1,5 @@
type (->) :: * -> * -> *
-type (->) = (->) :: * -> * -> *
+type (->) = FUN 'Many :: * -> * -> *
-- Defined in ‘GHC.Types’
infixr -1 ->
instance Applicative ((->) r) -- Defined in ‘GHC.Base’
=====================================
testsuite/tests/ghci/scripts/T8535.stdout
=====================================
@@ -1,5 +1,5 @@
type (->) :: * -> * -> *
-type (->) = (->) :: * -> * -> *
+type (->) = FUN 'Many :: * -> * -> *
-- Defined in ‘GHC.Types’
infixr -1 ->
instance Applicative ((->) r) -- Defined in ‘GHC.Base’
=====================================
testsuite/tests/ghci/scripts/ghci020.stdout
=====================================
@@ -1,5 +1,5 @@
type (->) :: * -> * -> *
-type (->) = (->) :: * -> * -> *
+type (->) = FUN 'Many :: * -> * -> *
-- Defined in ‘GHC.Types’
infixr -1 ->
instance Applicative ((->) r) -- Defined in ‘GHC.Base’
=====================================
testsuite/tests/ghci/should_run/T10145.stdout
=====================================
@@ -1,5 +1,5 @@
type (->) :: * -> * -> *
-type (->) = (->) :: * -> * -> *
+type (->) = FUN 'Many :: * -> * -> *
-- Defined in ‘GHC.Types’
infixr -1 ->
instance Applicative ((->) r) -- Defined in ‘GHC.Base’
=====================================
testsuite/tests/ghci/should_run/T18594.script
=====================================
@@ -0,0 +1,6 @@
+:m GHC.Types
+:i (->)
+:set -XStarIsType
+:i Type
+:set -XNoStarIsType
+:i Type
=====================================
testsuite/tests/ghci/should_run/T18594.stdout
=====================================
@@ -0,0 +1,15 @@
+type (->) :: * -> * -> *
+type (->) = FUN 'Many :: * -> * -> *
+ -- Defined in ‘GHC.Types’
+infixr -1 ->
+instance Applicative ((->) r) -- Defined in ‘GHC.Base’
+instance Functor ((->) r) -- Defined in ‘GHC.Base’
+instance Monad ((->) r) -- Defined in ‘GHC.Base’
+instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’
+instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’
+type Type :: *
+type Type = TYPE 'LiftedRep
+ -- Defined in ‘GHC.Types’
+type Type :: Type
+type Type = TYPE 'LiftedRep
+ -- Defined in ‘GHC.Types’
=====================================
testsuite/tests/ghci/should_run/all.T
=====================================
@@ -75,3 +75,4 @@ test('T18064',
],
ghci_script,
['T18064.script'])
+test('T18594', just_ghci, ghci_script, ['T18594.script'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3f50154591ada9064351ccec4adfe6df53ca2439...d8f61182c3bdd1b6121c83be632b4941b907de88
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3f50154591ada9064351ccec4adfe6df53ca2439...d8f61182c3bdd1b6121c83be632b4941b907de88
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/20200824/cda07a8d/attachment-0001.html>
More information about the ghc-commits
mailing list