diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Syntax.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Type.hs | 26 | ||||
| -rw-r--r-- | compiler/GHC/Utils/Outputable.hs | 2 |
4 files changed, 35 insertions, 4 deletions
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index b5ded38737..2c6c3affbd 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/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 } diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index 842bb2815a..bd576b26cf 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/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 diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index 52d07f0fcb..1067e6cab3 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/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,12 +1380,14 @@ 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' ctxt_prec tc tys (PrintExplicitKinds print_kinds) + print_type_abbreviations debug pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceAppArgs - -> PrintExplicitKinds -> Bool -> SDoc -pprTyTcApp' ctxt_prec tc tys printExplicitKinds debug + -> PrintExplicitKinds -> Bool -> Bool -> SDoc +pprTyTcApp' ctxt_prec tc tys printExplicitKinds printTypeAbbreviations debug | ifaceTyConName tc `hasKey` ipClassKey , IA_Arg (IfaceLitTy (IfaceStrTyLit n)) Required (IA_Arg ty Required IA_Nil) <- tys @@ -1393,11 +1411,13 @@ pprTyTcApp' ctxt_prec tc tys printExplicitKinds debug | tc `ifaceTyConHasKey` tYPETyConKey , IA_Arg (IfaceTyConApp rep IA_Nil) Required IA_Nil <- tys , rep `ifaceTyConHasKey` liftedRepDataConKey + , printTypeAbbreviations -- 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 + , printTypeAbbreviations -- See Note [Printing type abbreviations] = pprIfacePrefixApp ctxt_prec (parens arrow) (map (ppr_ty appPrec) (appArgsIfaceTypes $ stripInvisArgs printExplicitKinds args)) | otherwise diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index 1875d8faf9..23bceff20a 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/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" } |