diff options
| -rw-r--r-- | compiler/GHC/Core/Coercion.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Core/TyCo/Ppr.hs | 15 | ||||
| -rw-r--r-- | compiler/GHC/CoreToIface.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/CoreToIface.hs-boot | 13 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Syntax.hs | 8 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Type.hs | 1523 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Type.hs-boot | 15 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Type/Ppr.hs | 1399 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Type/Ppr.hs-boot | 21 | ||||
| -rw-r--r-- | compiler/Language/Haskell/Syntax/Extension.hs | 5 |
10 files changed, 1659 insertions, 1345 deletions
diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index ef6d4af5ec..c1b8d20387 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -133,6 +133,7 @@ import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs) import GHC.Prelude import GHC.Iface.Type +import GHC.Iface.Type.Ppr import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs index 2929474d84..2ae2562ec3 100644 --- a/compiler/GHC/Core/TyCo/Ppr.hs +++ b/compiler/GHC/Core/TyCo/Ppr.hs @@ -44,6 +44,7 @@ import GHC.Core.Class import GHC.Types.Var import GHC.Iface.Type +import GHC.Iface.Type.Ppr import GHC.Types.Var.Set import GHC.Types.Var.Env @@ -106,17 +107,17 @@ pprKind, pprParendKind :: Kind -> SDoc pprKind = pprType pprParendKind = pprParendType -tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType +tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceTypePpr tidyToIfaceTypeStyX env ty sty | userStyle sty = tidyToIfaceTypeX env ty | otherwise = toIfaceTypeX (tyCoVarsOfType ty) ty -- in latter case, don't tidy, as we'll be printing uniques. -tidyToIfaceType :: Type -> IfaceType +tidyToIfaceType :: Type -> IfaceTypePpr tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv -tidyToIfaceTypeX :: TidyEnv -> Type -> IfaceType --- It's vital to tidy before converting to an IfaceType +tidyToIfaceTypeX :: TidyEnv -> Type -> IfaceTypePpr +-- It's vital to tidy before converting to an IfaceTypePpr -- or nested binders will become indistinguishable! -- -- Also for the free type variables, tell toIfaceTypeX to @@ -132,14 +133,14 @@ pprCo, pprParendCo :: Coercion -> SDoc pprCo co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty) pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty) -tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion +tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercionPpr tidyToIfaceCoSty co sty | userStyle sty = tidyToIfaceCo co | otherwise = toIfaceCoercionX (tyCoVarsOfCo co) co -- in latter case, don't tidy, as we'll be printing uniques. -tidyToIfaceCo :: Coercion -> IfaceCoercion --- It's vital to tidy before converting to an IfaceType +tidyToIfaceCo :: Coercion -> IfaceCoercionPpr +-- It's vital to tidy before converting to an IfaceTypePpr -- or nested binders will become indistinguishable! -- -- Also for the free type variables, tell toIfaceCoercionX to diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index 11fd63e0bc..bd2632d0e0 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -138,7 +138,7 @@ toIfaceBndr var | isId var = IfaceIdBndr (toIfaceIdBndr var) | otherwise = IfaceTvBndr (toIfaceTvBndr var) -toIfaceBndrX :: VarSet -> Var -> IfaceBndr +toIfaceBndrX :: VarSet -> Var -> IfaceBndrPpr toIfaceBndrX fr var | isId var = IfaceIdBndr (toIfaceIdBndrX fr var) | otherwise = IfaceTvBndr (toIfaceTvBndrX fr var) @@ -164,7 +164,7 @@ toIfaceKind = toIfaceType toIfaceType :: Type -> IfaceType toIfaceType = toIfaceTypeX emptyVarSet -toIfaceTypeX :: VarSet -> Type -> IfaceType +toIfaceTypeX :: VarSet -> Type -> IfaceTypePpr -- (toIfaceTypeX free ty) -- translates the tyvars in 'free' as IfaceFreeTyVars -- diff --git a/compiler/GHC/CoreToIface.hs-boot b/compiler/GHC/CoreToIface.hs-boot index a906414aaf..1739abfdbb 100644 --- a/compiler/GHC/CoreToIface.hs-boot +++ b/compiler/GHC/CoreToIface.hs-boot @@ -3,16 +3,19 @@ module GHC.CoreToIface where import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, TyLit, Coercion ) import {-# SOURCE #-} GHC.Iface.Type( IfaceType, IfaceTyCon, IfaceBndr , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) +import {-# SOURCE #-} GHC.Iface.Type.Ppr + ( IfaceTypePpr, IfaceBndrPpr + , IfaceCoercionPpr, IfaceAppArgsPpr ) import GHC.Types.Var ( VarBndr, TyCoVar ) import GHC.Types.Var.Env ( TidyEnv ) import GHC.Core.TyCon ( TyCon ) import GHC.Types.Var.Set( VarSet ) -- For GHC.Core.TyCo.Rep -toIfaceTypeX :: VarSet -> Type -> IfaceType +toIfaceTypeX :: VarSet -> Type -> IfaceTypePpr toIfaceTyLit :: TyLit -> IfaceTyLit -toIfaceForAllBndr :: (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag) +toIfaceForAllBndr :: (VarBndr TyCoVar flag) -> (VarBndr IfaceBndrPpr flag) toIfaceTyCon :: TyCon -> IfaceTyCon -toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs -toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion -tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs +toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgsPpr +toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercionPpr +tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgsPpr diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index c735a2f94f..9fc689c952 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -46,6 +46,7 @@ import GHC.Prelude import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey ) import GHC.Types.Unique ( hasKey ) import GHC.Iface.Type +import GHC.Iface.Type.Ppr import GHC.Iface.Recomp.Binary import GHC.Core( IsOrphan, isOrphan ) import GHC.Types.Demand @@ -69,6 +70,8 @@ import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import GHC.Builtin.Types ( constraintKindTyConName ) import GHC.Stg.InferTags.TagSig +import Language.Haskell.Syntax.Extension ( dataConCantHappen ) + import GHC.Utils.Lexeme (isLexSym) import GHC.Utils.Fingerprint import GHC.Utils.Binary @@ -1647,7 +1650,7 @@ freeNamesIfAppArgs (IA_Arg t _ ts) = freeNamesIfType t &&& freeNamesIfAppArgs ts freeNamesIfAppArgs IA_Nil = emptyNameSet freeNamesIfType :: IfaceType -> NameSet -freeNamesIfType (IfaceFreeTyVar _) = emptyNameSet +freeNamesIfType (XIfaceType x) = dataConCantHappen x freeNamesIfType (IfaceTyVar _) = emptyNameSet freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfAppArgs t freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs ts @@ -1674,9 +1677,8 @@ freeNamesIfCoercion (IfaceAppCo c1 c2) = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 freeNamesIfCoercion (IfaceForAllCo _ kind_co co) = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co -freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet +freeNamesIfCoercion (XIfaceCoercion x) = dataConCantHappen x freeNamesIfCoercion (IfaceCoVarCo _) = emptyNameSet -freeNamesIfCoercion (IfaceHoleCo _) = emptyNameSet freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos) = unitNameSet ax &&& fnList freeNamesIfCoercion cos freeNamesIfCoercion (IfaceUnivCo p _ t1 t2) diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index 4ee786fac6..378e9729ed 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -6,29 +6,48 @@ This module defines interface types and binders -} - +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -- FlexibleInstances for Binary (DefMethSpec IfaceType) {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} + +-- For NFData instance +{-# LANGUAGE UndecidableInstances #-} module GHC.Iface.Type ( IfExtName, IfLclName, - IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..), - IfaceMCoercion(..), - IfaceUnivCoProv(..), + IfaceType'(..), IfaceKind', + IfaceContext', IfacePredType', + IfaceCoercion'(..),IfaceMCoercion'(..), + IfaceUnivCoProv'(..), + IfaceMult', + IfaceAppArgs'(..), + IfaceBndr'(..), + IfaceTvBndr', IfaceIdBndr', + IfaceTyConBinder', IfaceForAllBndr', IfaceForAllSpecBndr', + XXIfaceType, XXIfaceCoercion, + + IfaceType, IfaceKind, + IfaceContext, IfacePredType, + IfaceCoercion,IfaceMCoercion, + IfaceUnivCoProv, IfaceMult, + IfaceAppArgs, + IfaceBndr, + IfaceTvBndr, IfaceIdBndr, + IfaceTyConBinder, IfaceForAllBndr, IfaceForAllSpecBndr, + IfaceTyCon(..), IfaceTyConInfo(..), mkIfaceTyConInfo, IfaceTyConSort(..), - IfaceTyLit(..), IfaceAppArgs(..), - IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, - IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder, - IfaceForAllSpecBndr, - IfaceForAllBndr, ArgFlag(..), AnonArgFlag(..), ShowForAllFlag(..), + IfaceTyLit(..), + IfaceOneShot(..), IfaceLamBndr, + ArgFlag(..), AnonArgFlag(..), mkIfaceForAllTvBndr, mkIfaceTyConKind, ifaceForAllSpecToBndrs, ifaceForAllSpecToBndr, @@ -38,30 +57,26 @@ module GHC.Iface.Type ( -- Equality testing isIfaceLiftedTypeKind, + isIfaceTyConAppLiftedTypeKind, + + ifaceTyConHasKey, -- Conversion from IfaceAppArgs to IfaceTypes/ArgFlags appArgsIfaceTypes, appArgsIfaceTypesArgFlags, + ifaceVisAppArgsLength, -- Printing - SuppressBndrSig(..), - UseBndrParens(..), PrintExplicitKinds(..), - pprIfaceType, pprParendIfaceType, pprPrecIfaceType, - pprIfaceContext, pprIfaceContextArr, - pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders, - pprIfaceBndrs, pprIfaceAppArgs, pprParendIfaceAppArgs, - pprIfaceForAllPart, pprIfaceForAllPartMust, pprIfaceForAll, - pprIfaceSigmaType, pprIfaceTyLit, - pprIfaceCoercion, pprParendIfaceCoercion, - splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll, - pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp, - ppr_fun_arrow, - isIfaceTauType, + pprIfaceTyLit, + pprPromotionQuote, + pprPromotionQuoteI, suppressIfaceInvisibles, stripIfaceInvisVars, stripInvisArgs, + splitIfaceSigmaTy, splitIfaceReqForallTy, + mkIfaceTySubst, substIfaceTyVar, substIfaceAppArgs, inDomIfaceTySubst, many_ty @@ -69,18 +84,12 @@ module GHC.Iface.Type ( import GHC.Prelude -import {-# SOURCE #-} GHC.Builtin.Types - ( coercibleTyCon, heqTyCon - , tupleTyConName - , manyDataConTyCon, oneDataConTyCon - , liftedRepTyCon, liftedDataConTyCon ) -import {-# SOURCE #-} GHC.Core.Type ( isRuntimeRepTy, isMultiplicityTy, isLevityTy ) +import {-# SOURCE #-} GHC.Builtin.Types ( manyDataConTyCon ) import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom import GHC.Types.Var import GHC.Builtin.Names -import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKindTyConName ) import GHC.Types.Name import GHC.Types.Basic import GHC.Utils.Binary @@ -88,7 +97,8 @@ import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Panic -import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isMetaTyVar, isTyConableTyVar ) + +import Language.Haskell.Syntax.Extension ( DataConCantHappen, dataConCantHappen ) import Data.Maybe( isJust ) import qualified Data.Semigroup as Semi @@ -107,24 +117,29 @@ type IfLclName = FastString -- A local name in iface syntax type IfExtName = Name -- An External or WiredIn Name can appear in Iface syntax -- (However Internal or System Names never should) -data IfaceBndr -- Local (non-top-level) binders - = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr - | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr +data IfaceBndr' p -- Local (non-top-level) binders + = IfaceIdBndr {-# UNPACK #-} !(IfaceIdBndr' p) + | IfaceTvBndr {-# UNPACK #-} !(IfaceTvBndr' p) -type IfaceIdBndr = (IfaceType, IfLclName, IfaceType) -type IfaceTvBndr = (IfLclName, IfaceKind) +type IfaceIdBndr' p = (IfaceType' p, IfLclName, IfaceType' p) +type IfaceTvBndr' p = (IfLclName, IfaceKind' p) -ifaceTvBndrName :: IfaceTvBndr -> IfLclName +type IfaceBndr = IfaceBndr' TtgIface + +type IfaceTvBndr = IfaceTvBndr' TtgIface +type IfaceIdBndr = IfaceIdBndr' TtgIface + +ifaceTvBndrName :: IfaceTvBndr' p -> IfLclName ifaceTvBndrName (n,_) = n -ifaceIdBndrName :: IfaceIdBndr -> IfLclName +ifaceIdBndrName :: IfaceIdBndr' p -> IfLclName ifaceIdBndrName (_,n,_) = n -ifaceBndrName :: IfaceBndr -> IfLclName +ifaceBndrName :: IfaceBndr' p -> IfLclName ifaceBndrName (IfaceTvBndr bndr) = ifaceTvBndrName bndr ifaceBndrName (IfaceIdBndr bndr) = ifaceIdBndrName bndr -ifaceBndrType :: IfaceBndr -> IfaceType +ifaceBndrType :: IfaceBndr' p -> IfaceType' p ifaceBndrType (IfaceIdBndr (_, _, t)) = t ifaceBndrType (IfaceTvBndr (_, t)) = t @@ -153,36 +168,47 @@ type IfaceKind = IfaceType -- -- Any time a 'Type' is pretty-printed, it is first converted to an 'IfaceType' -- before being printed. See Note [Pretty printing via Iface syntax] in "GHC.Types.TyThing.Ppr" -data IfaceType - = IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType] - | IfaceTyVar IfLclName -- Type/coercion variable only, not tycon +data IfaceType' p + = IfaceTyVar IfLclName -- Type/coercion variable only, not tycon | IfaceLitTy IfaceTyLit - | IfaceAppTy IfaceType IfaceAppArgs + | IfaceAppTy (IfaceType' p) (IfaceAppArgs' p) -- See Note [Suppressing invisible arguments] for -- an explanation of why the second field isn't -- IfaceType, analogous to AppTy. - | IfaceFunTy AnonArgFlag IfaceMult IfaceType IfaceType - | IfaceForAllTy IfaceForAllBndr IfaceType - | IfaceTyConApp IfaceTyCon IfaceAppArgs -- Not necessarily saturated - -- Includes newtypes, synonyms, tuples - | IfaceCastTy IfaceType IfaceCoercion - | IfaceCoercionTy IfaceCoercion + | IfaceFunTy AnonArgFlag (IfaceMult' p) (IfaceType' p) (IfaceType' p) + | IfaceForAllTy (IfaceForAllBndr' p) (IfaceType' p) + | IfaceTyConApp IfaceTyCon (IfaceAppArgs' p) -- Not necessarily saturated + -- Includes newtypes, synonyms, tuples + | IfaceCastTy (IfaceType' p) (IfaceCoercion' p) + | IfaceCoercionTy (IfaceCoercion' p) | IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp) TupleSort -- What sort of tuple? PromotionFlag -- A bit like IfaceTyCon - IfaceAppArgs -- arity = length args + (IfaceAppArgs' p) -- arity = length args -- For promoted data cons, the kind args are omitted -- Why have this? Only for efficiency: IfaceTupleTy can omit the -- type arguments, as they can be recreated when deserializing. -- In an experiment, removing IfaceTupleTy resulted in a 0.75% regression -- in interface file size (in GHC's boot libraries). -- See !3987. + | XIfaceType (XXIfaceType p) + +type IfaceKind' p = IfaceType' p +type IfaceMult' p = IfaceType' p +type family XXIfaceType p + +data TtgIface +type instance XXIfaceType TtgIface = DataConCantHappen +type IfaceType = IfaceType' TtgIface type IfaceMult = IfaceType -type IfacePredType = IfaceType -type IfaceContext = [IfacePredType] +type IfacePredType' p = IfaceType' p +type IfaceContext' p = [IfacePredType' p] + +type IfacePredType = IfacePredType' TtgIface +type IfaceContext = IfaceContext' TtgIface data IfaceTyLit = IfaceNumTyLit Integer @@ -190,34 +216,38 @@ data IfaceTyLit | IfaceCharTyLit Char deriving (Eq) -type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis -type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag -type IfaceForAllSpecBndr = VarBndr IfaceBndr Specificity +type IfaceTyConBinder' p = VarBndr (IfaceBndr' p) TyConBndrVis +type IfaceForAllBndr' p = VarBndr (IfaceBndr' p) ArgFlag +type IfaceForAllSpecBndr' p = VarBndr (IfaceBndr' p) Specificity + +type IfaceTyConBinder = IfaceTyConBinder' TtgIface +type IfaceForAllBndr = IfaceForAllBndr' TtgIface +type IfaceForAllSpecBndr = IfaceForAllSpecBndr' TtgIface -- | Make an 'IfaceForAllBndr' from an 'IfaceTvBndr'. -mkIfaceForAllTvBndr :: ArgFlag -> IfaceTvBndr -> IfaceForAllBndr +mkIfaceForAllTvBndr :: ArgFlag -> IfaceTvBndr' p -> IfaceForAllBndr' p mkIfaceForAllTvBndr vis var = Bndr (IfaceTvBndr var) vis -- | Build the 'tyConKind' from the binders and the result kind. -- Keep in sync with 'mkTyConKind' in "GHC.Core.TyCon". -mkIfaceTyConKind :: [IfaceTyConBinder] -> IfaceKind -> IfaceKind +mkIfaceTyConKind :: [IfaceTyConBinder' p] -> IfaceKind' p -> IfaceKind' p mkIfaceTyConKind bndrs res_kind = foldr mk res_kind bndrs where - mk :: IfaceTyConBinder -> IfaceKind -> IfaceKind + mk :: IfaceTyConBinder' p -> IfaceKind' p -> IfaceKind' p mk (Bndr tv (AnonTCB af)) k = IfaceFunTy af many_ty (ifaceBndrType tv) k mk (Bndr tv (NamedTCB vis)) k = IfaceForAllTy (Bndr tv vis) k -ifaceForAllSpecToBndrs :: [IfaceForAllSpecBndr] -> [IfaceForAllBndr] +ifaceForAllSpecToBndrs :: [IfaceForAllSpecBndr' p] -> [IfaceForAllBndr' p] ifaceForAllSpecToBndrs = map ifaceForAllSpecToBndr -ifaceForAllSpecToBndr :: IfaceForAllSpecBndr -> IfaceForAllBndr +ifaceForAllSpecToBndr :: IfaceForAllSpecBndr' p -> IfaceForAllBndr' p ifaceForAllSpecToBndr (Bndr tv spec) = Bndr tv (Invisible spec) -- | Stores the arguments in a type application as a list. -- See @Note [Suppressing invisible arguments]@. -data IfaceAppArgs +data IfaceAppArgs' p = IA_Nil - | IA_Arg IfaceType -- The type argument + | IA_Arg (IfaceType' p) -- The type argument ArgFlag -- The argument's visibility. We store this here so -- that we can: @@ -229,16 +259,18 @@ data IfaceAppArgs -- specified arguments in @(...) and inferred -- arguments in @{...}. - IfaceAppArgs -- The rest of the arguments + (IfaceAppArgs' p) -- The rest of the arguments -instance Semi.Semigroup IfaceAppArgs where +instance Semi.Semigroup (IfaceAppArgs' p) where IA_Nil <> xs = xs IA_Arg ty argf rest <> xs = IA_Arg ty argf (rest Semi.<> xs) -instance Monoid IfaceAppArgs where +instance Monoid (IfaceAppArgs' p) where mempty = IA_Nil mappend = (Semi.<>) +type IfaceAppArgs = IfaceAppArgs' TtgIface + -- Encodes type constructors, kind constructors, -- coercion constructors, the lot. -- We have to tag them in order to pretty print them @@ -364,40 +396,49 @@ mkIfaceTyConInfo IsPromoted IfaceNormalTyCon = IfaceTyConInfo IsPromoted Iface mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = IfaceTyConInfo NotPromoted IfaceNormalTyCon mkIfaceTyConInfo prom sort = IfaceTyConInfo prom sort -data IfaceMCoercion +data IfaceMCoercion' p = IfaceMRefl - | IfaceMCo IfaceCoercion - -data IfaceCoercion - = IfaceReflCo IfaceType - | IfaceGReflCo Role IfaceType (IfaceMCoercion) - | IfaceFunCo Role IfaceCoercion IfaceCoercion IfaceCoercion - | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion] - | IfaceAppCo IfaceCoercion IfaceCoercion - | IfaceForAllCo IfaceBndr IfaceCoercion IfaceCoercion + | IfaceMCo (IfaceCoercion' p) + +data IfaceCoercion' p + = IfaceReflCo (IfaceType' p) + | IfaceGReflCo Role (IfaceType' p) (IfaceMCoercion' p) + | IfaceFunCo Role (IfaceCoercion' p) (IfaceCoercion' p) (IfaceCoercion' p) + | IfaceTyConAppCo Role IfaceTyCon [(IfaceCoercion' p)] + | IfaceAppCo (IfaceCoercion' p) (IfaceCoercion' p) + | IfaceForAllCo IfaceBndr (IfaceCoercion' p) (IfaceCoercion' p) | IfaceCoVarCo IfLclName - | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion] - | IfaceAxiomRuleCo IfLclName [IfaceCoercion] + | IfaceAxiomInstCo IfExtName BranchIndex [(IfaceCoercion' p)] + | IfaceAxiomRuleCo IfLclName [(IfaceCoercion' p)] -- There are only a fixed number of CoAxiomRules, so it suffices -- to use an IfaceLclName to distinguish them. -- See Note [Adding built-in type families] in GHC.Builtin.Types.Literals - | IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType - | IfaceSymCo IfaceCoercion - | IfaceTransCo IfaceCoercion IfaceCoercion - | IfaceNthCo Int IfaceCoercion - | IfaceLRCo LeftOrRight IfaceCoercion - | IfaceInstCo IfaceCoercion IfaceCoercion - | IfaceKindCo IfaceCoercion - | IfaceSubCo IfaceCoercion - | IfaceFreeCoVar CoVar -- See Note [Free tyvars in IfaceType] - | IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion] - -data IfaceUnivCoProv - = IfacePhantomProv IfaceCoercion - | IfaceProofIrrelProv IfaceCoercion + | IfaceUnivCo (IfaceUnivCoProv' p) Role (IfaceType' p) (IfaceType' p) + | IfaceSymCo (IfaceCoercion' p) + | IfaceTransCo (IfaceCoercion' p) (IfaceCoercion' p) + | IfaceNthCo Int (IfaceCoercion' p) + | IfaceLRCo LeftOrRight (IfaceCoercion' p) + | IfaceInstCo (IfaceCoercion' p) (IfaceCoercion' p) + | IfaceKindCo (IfaceCoercion' p) + | IfaceSubCo (IfaceCoercion' p) + | XIfaceCoercion (XXIfaceCoercion p) + +type family XXIfaceCoercion p + +type instance XXIfaceCoercion TtgIface = DataConCantHappen + +data IfaceUnivCoProv' p + = IfacePhantomProv (IfaceCoercion' p) + | IfaceProofIrrelProv (IfaceCoercion' p) | IfacePluginProv String | IfaceCorePrepProv Bool -- See defn of CorePrepProv +type IfaceMCoercion = IfaceMCoercion' TtgIface + +type IfaceCoercion = IfaceCoercion' TtgIface + +type IfaceUnivCoProv = IfaceUnivCoProv' TtgIface + {- Note [Holes in IfaceCoercion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When typechecking fails the typechecker will produce a HoleCo to stand @@ -420,7 +461,7 @@ ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key -- | Given a kind K, is K of the form (TYPE ('BoxedRep 'LiftedRep))? -isIfaceLiftedTypeKind :: IfaceKind -> Bool +isIfaceLiftedTypeKind :: IfaceKind' p -> Bool isIfaceLiftedTypeKind (IfaceTyConApp tc IA_Nil) = isLiftedTypeKindTyConName (ifaceTyConName tc) isIfaceLiftedTypeKind (IfaceTyConApp tc1 args1) @@ -435,7 +476,7 @@ isIfaceLiftedTypeKind _ = False -- -- For the second condition, we must also check for the type -- synonym LiftedRep. -isIfaceTyConAppLiftedTypeKind :: IfaceTyCon -> IfaceAppArgs -> Bool +isIfaceTyConAppLiftedTypeKind :: IfaceTyCon -> IfaceAppArgs' p -> Bool isIfaceTyConAppLiftedTypeKind tc1 args1 | tc1 `ifaceTyConHasKey` tYPETyConKey , IA_Arg soleArg1 Required IA_Nil <- args1 @@ -449,7 +490,7 @@ isIfaceTyConAppLiftedTypeKind tc1 args1 | otherwise -> False | otherwise = False -splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType) +splitIfaceSigmaTy :: IfaceType' p -> ([IfaceForAllBndr' p], [IfacePredType' p], IfaceType' p) -- Mainly for printing purposes -- -- Here we split nested IfaceSigmaTy properly. @@ -481,13 +522,15 @@ splitIfaceSigmaTy ty = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } split_rho tau = ([], tau) -splitIfaceReqForallTy :: IfaceType -> ([IfaceForAllBndr], IfaceType) +splitIfaceReqForallTy :: IfaceType' p -> ([IfaceForAllBndr' p], IfaceType' p) splitIfaceReqForallTy (IfaceForAllTy bndr ty) | isVisibleArgFlag (binderArgFlag bndr) = case splitIfaceReqForallTy ty of { (bndrs, rho) -> (bndr:bndrs, rho) } splitIfaceReqForallTy rho = ([], rho) -suppressIfaceInvisibles :: PrintExplicitKinds -> [IfaceTyConBinder] -> [a] -> [a] +newtype PrintExplicitKinds = PrintExplicitKinds Bool + +suppressIfaceInvisibles :: PrintExplicitKinds -> [IfaceTyConBinder' p] -> [a] -> [a] suppressIfaceInvisibles (PrintExplicitKinds True) _tys xs = xs suppressIfaceInvisibles (PrintExplicitKinds False) tys xs = suppress tys xs where @@ -497,68 +540,49 @@ suppressIfaceInvisibles (PrintExplicitKinds False) tys xs = suppress tys xs | isInvisibleTyConBinder k = suppress ks xs | otherwise = x : suppress ks xs -stripIfaceInvisVars :: PrintExplicitKinds -> [IfaceTyConBinder] -> [IfaceTyConBinder] +stripIfaceInvisVars :: PrintExplicitKinds -> [IfaceTyConBinder' p] -> [IfaceTyConBinder' p] stripIfaceInvisVars (PrintExplicitKinds True) tyvars = tyvars stripIfaceInvisVars (PrintExplicitKinds False) tyvars = filterOut isInvisibleTyConBinder tyvars -- | Extract an 'IfaceBndr' from an 'IfaceForAllBndr'. -ifForAllBndrVar :: IfaceForAllBndr -> IfaceBndr +ifForAllBndrVar :: IfaceForAllBndr' p -> IfaceBndr' p ifForAllBndrVar = binderVar -- | Extract the variable name from an 'IfaceForAllBndr'. -ifForAllBndrName :: IfaceForAllBndr -> IfLclName +ifForAllBndrName :: IfaceForAllBndr' p -> IfLclName ifForAllBndrName fab = ifaceBndrName (ifForAllBndrVar fab) -- | Extract an 'IfaceBndr' from an 'IfaceTyConBinder'. -ifTyConBinderVar :: IfaceTyConBinder -> IfaceBndr +ifTyConBinderVar :: IfaceTyConBinder' p -> IfaceBndr' p ifTyConBinderVar = binderVar -- | Extract the variable name from an 'IfaceTyConBinder'. -ifTyConBinderName :: IfaceTyConBinder -> IfLclName +ifTyConBinderName :: IfaceTyConBinder' p -> IfLclName ifTyConBinderName tcb = ifaceBndrName (ifTyConBinderVar tcb) -ifTypeIsVarFree :: IfaceType -> Bool --- Returns True if the type definitely has no variables at all --- Just used to control pretty printing -ifTypeIsVarFree ty = go ty - where - go (IfaceTyVar {}) = False - go (IfaceFreeTyVar {}) = False - go (IfaceAppTy fun args) = go fun && go_args args - go (IfaceFunTy _ w arg res) = go w && go arg && go res - go (IfaceForAllTy {}) = False - go (IfaceTyConApp _ args) = go_args args - go (IfaceTupleTy _ _ args) = go_args args - go (IfaceLitTy _) = True - go (IfaceCastTy {}) = False -- Safe - go (IfaceCoercionTy {}) = False -- Safe - - go_args IA_Nil = True - go_args (IA_Arg arg _ args) = go arg && go_args args - {- Note [Substitution on IfaceType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Substitutions on IfaceType are done only during pretty-printing to construct the result type of a GADT, and does not deal with binders (eg IfaceForAll), so it doesn't need fancy capture stuff. -} -type IfaceTySubst = FastStringEnv IfaceType -- Note [Substitution on IfaceType] +type IfaceTySubst' p = FastStringEnv (IfaceType' p) -- Note [Substitution on IfaceType] -mkIfaceTySubst :: [(IfLclName,IfaceType)] -> IfaceTySubst +mkIfaceTySubst :: [(IfLclName, IfaceType' p)] -> IfaceTySubst' p -- See Note [Substitution on IfaceType] mkIfaceTySubst eq_spec = mkFsEnv eq_spec -inDomIfaceTySubst :: IfaceTySubst -> IfaceTvBndr -> Bool +inDomIfaceTySubst :: IfaceTySubst' p -> IfaceTvBndr' p -> Bool -- See Note [Substitution on IfaceType] inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst fs) -substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType +substIfaceType :: Outputable (IfaceType' p) => IfaceTySubst' p -> IfaceType' p -> IfaceType' p -- See Note [Substitution on IfaceType] substIfaceType env ty = go ty where - go (IfaceFreeTyVar tv) = IfaceFreeTyVar tv + go ty@(XIfaceType _) = ty -- assume extension unsubstituted for now go (IfaceTyVar tv) = substIfaceTyVar env tv go (IfaceAppTy t ts) = IfaceAppTy (go t) (substIfaceAppArgs env ts) go (IfaceFunTy af w t1 t2) = IfaceFunTy af (go w) (go t1) (go t2) @@ -572,15 +596,14 @@ substIfaceType env ty go_mco IfaceMRefl = IfaceMRefl go_mco (IfaceMCo co) = IfaceMCo $ go_co co + go_co co@(XIfaceCoercion _) = co -- assume extension unsubstituted for now go_co (IfaceReflCo ty) = IfaceReflCo (go ty) go_co (IfaceGReflCo r ty mco) = IfaceGReflCo r (go ty) (go_mco mco) go_co (IfaceFunCo r w c1 c2) = IfaceFunCo r (go_co w) (go_co c1) (go_co c2) go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos) go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2) go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty) - go_co (IfaceFreeCoVar cv) = IfaceFreeCoVar cv go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv - go_co (IfaceHoleCo cv) = IfaceHoleCo cv go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos) go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2) go_co (IfaceSymCo co) = IfaceSymCo (go_co co) @@ -599,14 +622,14 @@ substIfaceType env ty go_prov co@(IfacePluginProv _) = co go_prov co@(IfaceCorePrepProv _) = co -substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs +substIfaceAppArgs :: Outputable (IfaceType' p) => IfaceTySubst' p -> IfaceAppArgs' p -> IfaceAppArgs' p substIfaceAppArgs env args = go args where go IA_Nil = IA_Nil go (IA_Arg ty arg tys) = IA_Arg (substIfaceType env ty) arg (go tys) -substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType +substIfaceTyVar :: IfaceTySubst' p -> IfLclName -> IfaceType' p substIfaceTyVar env tv | Just ty <- lookupFsEnv env tv = ty | otherwise = IfaceTyVar tv @@ -620,7 +643,7 @@ substIfaceTyVar env tv ************************************************************************ -} -stripInvisArgs :: PrintExplicitKinds -> IfaceAppArgs -> IfaceAppArgs +stripInvisArgs :: PrintExplicitKinds -> IfaceAppArgs' p -> IfaceAppArgs' p stripInvisArgs (PrintExplicitKinds True) tys = tys stripInvisArgs (PrintExplicitKinds False) tys = suppress_invis tys where @@ -637,16 +660,16 @@ stripInvisArgs (PrintExplicitKinds False) tys = suppress_invis tys | otherwise -> suppress_invis ts -appArgsIfaceTypes :: IfaceAppArgs -> [IfaceType] +appArgsIfaceTypes :: IfaceAppArgs' p -> [IfaceType' p] appArgsIfaceTypes IA_Nil = [] appArgsIfaceTypes (IA_Arg t _ ts) = t : appArgsIfaceTypes ts -appArgsIfaceTypesArgFlags :: IfaceAppArgs -> [(IfaceType, ArgFlag)] +appArgsIfaceTypesArgFlags :: IfaceAppArgs' p -> [(IfaceType' p, ArgFlag)] appArgsIfaceTypesArgFlags IA_Nil = [] appArgsIfaceTypesArgFlags (IA_Arg t a ts) = (t, a) : appArgsIfaceTypesArgFlags ts -ifaceVisAppArgsLength :: IfaceAppArgs -> Int +ifaceVisAppArgsLength :: IfaceAppArgs' p -> Int ifaceVisAppArgsLength = go 0 where go !n IA_Nil = n @@ -654,96 +677,14 @@ ifaceVisAppArgsLength = go 0 | isVisibleArgFlag argf = go (n+1) rest | otherwise = go n rest -{- -Note [Suppressing invisible arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use the IfaceAppArgs data type to specify which of the arguments to a type -should be displayed when pretty-printing, under the control of --fprint-explicit-kinds. -See also Type.filterOutInvisibleTypes. -For example, given - - T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism - 'Just :: forall k. k -> 'Maybe k -- Promoted - -we want - - T * Tree Int prints as T Tree Int - 'Just * prints as Just * - -For type constructors (IfaceTyConApp), IfaceAppArgs is a quite natural fit, -since the corresponding Core constructor: - - data Type - = ... - | TyConApp TyCon [Type] - -Already puts all of its arguments into a list. So when converting a Type to an -IfaceType (see toIfaceAppArgsX in GHC.Core.ToIface), we simply use the kind of -the TyCon (which is cached) to guide the process of converting the argument -Types into an IfaceAppArgs list. - -We also want this behavior for IfaceAppTy, since given: - - data Proxy (a :: k) - f :: forall (t :: forall a. a -> Type). Proxy Type (t Bool True) - -We want to print the return type as `Proxy (t True)` without the use of --fprint-explicit-kinds (#15330). Accomplishing this is trickier than in the -tycon case, because the corresponding Core constructor for IfaceAppTy: - - data Type - = ... - | AppTy Type Type - -Only stores one argument at a time. Therefore, when converting an AppTy to an -IfaceAppTy (in toIfaceTypeX in GHC.CoreToIface), we: - -1. Flatten the chain of AppTys down as much as possible -2. Use typeKind to determine the function Type's kind -3. Use this kind to guide the process of converting the argument Types into an - IfaceAppArgs list. - -By flattening the arguments like this, we obtain two benefits: - -(a) We can reuse the same machinery to pretty-print IfaceTyConApp arguments as - we do IfaceTyApp arguments, which means that we only need to implement the - logic to filter out invisible arguments once. -(b) Unlike for tycons, finding the kind of a type in general (through typeKind) - is not a constant-time operation, so by flattening the arguments first, we - decrease the number of times we have to call typeKind. - -Note [Pretty-printing invisible arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note [Suppressing invisible arguments] is all about how to avoid printing -invisible arguments when the -fprint-explicit-kinds flag is disables. Well, -what about when it's enabled? Then we can and should print invisible kind -arguments, and this Note explains how we do it. - -As two running examples, consider the following code: - - {-# LANGUAGE PolyKinds #-} - data T1 a - data T2 (a :: k) - -When displaying these types (with -fprint-explicit-kinds on), we could just -do the following: - - T1 k a - T2 k a - -That certainly gets the job done. But it lacks a crucial piece of information: -is the `k` argument inferred or specified? To communicate this, we use visible -kind application syntax to distinguish the two cases: - - T1 @{k} a - T2 @k a - -Here, @{k} indicates that `k` is an inferred argument, and @k indicates that -`k` is a specified argument. (See -Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep for -a lengthier explanation on what "inferred" and "specified" mean.) +-- | The type 'Many :: Multiplicity'. +many_ty :: IfaceType' p +many_ty = + IfaceTyConApp (IfaceTyCon dc_name (mkIfaceTyConInfo IsPromoted IfaceNormalTyCon)) + IA_Nil + where dc_name = getName manyDataConTyCon +{- ************************************************************************ * * Pretty-printing @@ -751,121 +692,38 @@ a lengthier explanation on what "inferred" and "specified" mean.) ************************************************************************ -} -if_print_coercions :: SDoc -- ^ if printing coercions - -> SDoc -- ^ otherwise - -> SDoc -if_print_coercions yes no - = sdocOption sdocPrintExplicitCoercions $ \print_co -> - getPprStyle $ \style -> - getPprDebug $ \debug -> - if print_co || dumpStyle style || debug - then yes - else no - -pprIfaceInfixApp :: PprPrec -> SDoc -> SDoc -> SDoc -> SDoc -pprIfaceInfixApp ctxt_prec pp_tc pp_ty1 pp_ty2 - = maybeParen ctxt_prec opPrec $ - sep [pp_ty1, pp_tc <+> pp_ty2] - -pprIfacePrefixApp :: PprPrec -> SDoc -> [SDoc] -> SDoc -pprIfacePrefixApp ctxt_prec pp_fun pp_tys - | null pp_tys = pp_fun - | otherwise = maybeParen ctxt_prec appPrec $ - hang pp_fun 2 (sep pp_tys) - -isIfaceTauType :: IfaceType -> Bool -isIfaceTauType (IfaceForAllTy _ _) = False -isIfaceTauType (IfaceFunTy InvisArg _ _ _) = False -isIfaceTauType _ = True - --- ----------------------------- Printing binders ------------------------------------ - -instance Outputable IfaceBndr where - ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr - ppr (IfaceTvBndr bndr) = char '@' <> pprIfaceTvBndr bndr (SuppressBndrSig False) - (UseBndrParens False) - -pprIfaceBndrs :: [IfaceBndr] -> SDoc -pprIfaceBndrs bs = sep (map ppr bs) - -pprIfaceLamBndr :: IfaceLamBndr -> SDoc -pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b -pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]" - -pprIfaceIdBndr :: IfaceIdBndr -> SDoc -pprIfaceIdBndr (w, name, ty) = parens (ppr name <> brackets (ppr w) <+> dcolon <+> ppr ty) - -{- Note [Suppressing binder signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When printing the binders in a 'forall', we want to keep the kind annotations: +instance Outputable IfaceTyLit where + ppr = pprIfaceTyLit - forall (a :: k). blah - ^^^^ - good +pprIfaceTyLit :: IfaceTyLit -> SDoc +pprIfaceTyLit (IfaceNumTyLit n) = integer n +pprIfaceTyLit (IfaceStrTyLit n) = text (show n) +pprIfaceTyLit (IfaceCharTyLit c) = text (show c) -On the other hand, when we print the binders of a data declaration in :info, -the kind information would be redundant due to the standalone kind signature: +instance Outputable IfaceTyCon where + ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc) - type F :: Symbol -> Type - type F (s :: Symbol) = blah - ^^^^^^^^^ - redundant +instance Outputable IfaceTyConInfo where + ppr (IfaceTyConInfo { ifaceTyConIsPromoted = prom + , ifaceTyConSort = sort }) + = angleBrackets $ ppr prom <> comma <+> ppr sort -Here we'd like to omit the kind annotation: +pprPromotionQuote :: IfaceTyCon -> SDoc +pprPromotionQuote tc = + pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc - type F :: Symbol -> Type - type F s = blah +pprPromotionQuoteI :: PromotionFlag -> SDoc +pprPromotionQuoteI NotPromoted = empty +pprPromotionQuoteI IsPromoted = char '\'' -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 representation 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. +{- +************************************************************************ +* * + Instances +* * +************************************************************************ -} --- | Do we want to suppress kind annotations on binders? --- See Note [Suppressing binder signatures] -newtype SuppressBndrSig = SuppressBndrSig Bool - -newtype UseBndrParens = UseBndrParens Bool -newtype PrintExplicitKinds = PrintExplicitKinds Bool - -pprIfaceTvBndr :: IfaceTvBndr -> SuppressBndrSig -> UseBndrParens -> SDoc -pprIfaceTvBndr (tv, ki) (SuppressBndrSig suppress_sig) (UseBndrParens use_parens) - | suppress_sig = ppr tv - | isIfaceLiftedTypeKind ki = ppr tv - | otherwise = maybe_parens (ppr tv <+> dcolon <+> ppr ki) - where - maybe_parens | use_parens = parens - | otherwise = id - -pprIfaceTyConBinders :: SuppressBndrSig -> [IfaceTyConBinder] -> SDoc -pprIfaceTyConBinders suppress_sig = sep . map go - where - go :: IfaceTyConBinder -> SDoc - go (Bndr (IfaceIdBndr bndr) _) = pprIfaceIdBndr bndr - go (Bndr (IfaceTvBndr bndr) vis) = - -- See Note [Pretty-printing invisible arguments] - case vis of - AnonTCB VisArg -> ppr_bndr (UseBndrParens True) - AnonTCB InvisArg -> char '@' <> braces (ppr_bndr (UseBndrParens False)) - -- The above case is rare. (See Note [AnonTCB InvisArg] in GHC.Core.TyCon.) - -- Should we print these differently? - NamedTCB Required -> ppr_bndr (UseBndrParens True) - NamedTCB Specified -> char '@' <> ppr_bndr (UseBndrParens True) - NamedTCB Inferred -> char '@' <> braces (ppr_bndr (UseBndrParens False)) - where - ppr_bndr = pprIfaceTvBndr bndr suppress_sig instance Binary IfaceBndr where put_ bh (IfaceIdBndr aa) = do @@ -893,930 +751,6 @@ instance Binary IfaceOneShot where 0 -> return IfaceNoOneShot _ -> return IfaceOneShot --- ----------------------------- Printing IfaceType ------------------------------------ - ---------------------------------- -instance Outputable IfaceType where - ppr ty = pprIfaceType ty - -pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc -pprIfaceType = pprPrecIfaceType topPrec -pprParendIfaceType = pprPrecIfaceType appPrec - -pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc --- We still need `hideNonStandardTypes`, since the `pprPrecIfaceType` may be --- called from other places, besides `:type` and `:info`. -pprPrecIfaceType prec ty = - hideNonStandardTypes (ppr_ty prec) ty - -ppr_fun_arrow :: IfaceMult -> SDoc -ppr_fun_arrow w - | (IfaceTyConApp tc _) <- w - , tc `ifaceTyConHasKey` (getUnique manyDataConTyCon) = arrow - | (IfaceTyConApp tc _) <- w - , tc `ifaceTyConHasKey` (getUnique oneDataConTyCon) = lollipop - | otherwise = mulArrow (pprIfaceType w) - -ppr_sigma :: PprPrec -> IfaceType -> SDoc -ppr_sigma ctxt_prec ty - = maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty) - -ppr_ty :: PprPrec -> IfaceType -> SDoc -ppr_ty ctxt_prec ty@(IfaceForAllTy {}) = ppr_sigma ctxt_prec ty -ppr_ty ctxt_prec ty@(IfaceFunTy InvisArg _ _ _) = ppr_sigma ctxt_prec ty - -ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reason for IfaceFreeTyVar! -ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [Free tyvars in IfaceType] -ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys -ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys -- always fully saturated -ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n - -- Function types -ppr_ty ctxt_prec (IfaceFunTy _ w ty1 ty2) -- Should be VisArg - = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. - maybeParen ctxt_prec funPrec $ - sep [ppr_ty funPrec ty1, sep (ppr_fun_tail w ty2)] - where - ppr_fun_tail wthis (IfaceFunTy VisArg wnext ty1 ty2) - = (ppr_fun_arrow wthis <+> ppr_ty funPrec ty1) : ppr_fun_tail wnext ty2 - ppr_fun_tail wthis other_ty - = [ppr_fun_arrow wthis <+> pprIfaceType other_ty] - -ppr_ty ctxt_prec (IfaceAppTy t ts) - = if_print_coercions - ppr_app_ty - ppr_app_ty_no_casts - where - ppr_app_ty = - sdocOption sdocPrintExplicitKinds $ \print_kinds -> - let tys_wo_kinds = appArgsIfaceTypesArgFlags $ stripInvisArgs - (PrintExplicitKinds print_kinds) ts - in pprIfacePrefixApp ctxt_prec - (ppr_ty funPrec t) - (map (ppr_app_arg appPrec) tys_wo_kinds) - - - -- Strip any casts from the head of the application - ppr_app_ty_no_casts = - case t of - IfaceCastTy head _ -> ppr_ty ctxt_prec (mk_app_tys head ts) - _ -> ppr_app_ty - - mk_app_tys :: IfaceType -> IfaceAppArgs -> IfaceType - mk_app_tys (IfaceTyConApp tc tys1) tys2 = - IfaceTyConApp tc (tys1 `mappend` tys2) - mk_app_tys t1 tys2 = IfaceAppTy t1 tys2 - -ppr_ty ctxt_prec (IfaceCastTy ty co) - = if_print_coercions - (parens (ppr_ty topPrec ty <+> text "|>" <+> ppr co)) - (ppr_ty ctxt_prec ty) - -ppr_ty ctxt_prec (IfaceCoercionTy co) - = if_print_coercions - (ppr_co ctxt_prec co) - (text "<>") - -{- Note [Defaulting RuntimeRep variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -RuntimeRep variables are considered by many (most?) users to be little -more than syntactic noise. When the notion was introduced there was a -significant and understandable push-back from those with pedagogy in -mind, which argued that RuntimeRep variables would throw a wrench into -nearly any teach approach since they appear in even the lowly ($) -function's type, - - ($) :: forall (w :: RuntimeRep) a (b :: TYPE w). (a -> b) -> a -> b - -which is significantly less readable than its non RuntimeRep-polymorphic type of - - ($) :: (a -> b) -> a -> b - -Moreover, unboxed types don't appear all that often in run-of-the-mill -Haskell programs, so it makes little sense to make all users pay this -syntactic overhead. - -For this reason it was decided that we would hide RuntimeRep variables -for now (see #11549). We do this by defaulting all type variables of -kind RuntimeRep to LiftedRep. -Likewise, we default all Multiplicity variables to Many. - -This is done in a pass right before pretty-printing -(defaultIfaceTyVarsOfKind, controlled by --fprint-explicit-runtime-reps and -XLinearTypes) - -This applies to /quantified/ variables like 'w' above. What about -variables that are /free/ in the type being printed, which certainly -happens in error messages. Suppose (#16074, #19361) we are reporting a -mismatch between skolems - (a :: RuntimeRep) ~ (b :: RuntimeRep) - or - (m :: Multiplicity) ~ Many -We certainly don't want to say "Can't match LiftedRep with LiftedRep" or -"Can't match Many with Many"! - -But if we are printing the type - (forall (a :: TYPE r). blah) -we do want to turn that (free) r into LiftedRep, so it prints as - (forall a. blah) - -We use isMetaTyVar to distinguish between those two situations: -metavariables are converted, skolem variables are not. - -There's one exception though: TyVarTv metavariables should not be defaulted, -as they appear during kind-checking of "newtype T :: TYPE r where..." -(test T18357a). Therefore, we additionally test for isTyConableTyVar. --} - --- | Default 'RuntimeRep' variables to 'LiftedRep', --- 'Levity' variables to 'Lifted', and 'Multiplicity' --- variables to 'Many'. For example: --- --- @ --- ($) :: forall (r :: GHC.Types.RuntimeRep) a (b :: TYPE r). --- (a -> b) -> a -> b --- Just :: forall (k :: Multiplicity) a. a % k -> Maybe a --- @ --- --- turns in to, --- --- @ ($) :: forall a (b :: *). (a -> b) -> a -> b @ --- @ Just :: forall a . a -> Maybe a @ --- --- We do this to prevent RuntimeRep, Levity and Multiplicity variables from --- incurring a significant syntactic overhead in otherwise simple --- type signatures (e.g. ($)). See Note [Defaulting RuntimeRep variables] --- and #11549 for further discussion. -defaultIfaceTyVarsOfKind :: Bool -- ^ default 'RuntimeRep'/'Levity' variables? - -> Bool -- ^ default 'Multiplicity' variables? - -> IfaceType -> IfaceType -defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv ty - where - go :: FastStringEnv IfaceType -- Set of enclosing forall-ed RuntimeRep/Levity/Multiplicity variables - -> IfaceType - -> IfaceType - go subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty) - | isInvisibleArgFlag argf -- Don't default *visible* quantification - -- or we get the mess in #13963 - , Just substituted_ty <- check_substitution var_kind - = let subs' = extendFsEnv subs var substituted_ty - -- Record that we should replace it with LiftedRep/Lifted/Many, - -- and recurse, discarding the forall - in go subs' ty - - go subs (IfaceForAllTy bndr ty) - = IfaceForAllTy (go_ifacebndr subs bndr) (go subs ty) - - go subs ty@(IfaceTyVar tv) = case lookupFsEnv subs tv of - Just s -> s - Nothing -> ty - - go _ ty@(IfaceFreeTyVar tv) - -- See Note [Defaulting RuntimeRep variables], about free vars - | def_rep - , GHC.Core.Type.isRuntimeRepTy (tyVarKind tv) - , isMetaTyVar tv - , isTyConableTyVar tv - = liftedRep_ty - | def_rep - , GHC.Core.Type.isLevityTy (tyVarKind tv) - , isMetaTyVar tv - , isTyConableTyVar tv - = lifted_ty - | def_mult - , GHC.Core.Type.isMultiplicityTy (tyVarKind tv) - , isMetaTyVar tv - , isTyConableTyVar tv - = many_ty - | otherwise - = ty - - go subs (IfaceTyConApp tc tc_args) - = IfaceTyConApp tc (go_args subs tc_args) - - go subs (IfaceTupleTy sort is_prom tc_args) - = IfaceTupleTy sort is_prom (go_args subs tc_args) - - go subs (IfaceFunTy af w arg res) - = IfaceFunTy af (go subs w) (go subs arg) (go subs res) - - go subs (IfaceAppTy t ts) - = IfaceAppTy (go subs t) (go_args subs ts) - - go subs (IfaceCastTy x co) - = IfaceCastTy (go subs x) co - - go _ ty@(IfaceLitTy {}) = ty - go _ ty@(IfaceCoercionTy {}) = ty - - go_ifacebndr :: FastStringEnv IfaceType -> IfaceForAllBndr -> IfaceForAllBndr - go_ifacebndr subs (Bndr (IfaceIdBndr (w, n, t)) argf) - = Bndr (IfaceIdBndr (w, n, go subs t)) argf - go_ifacebndr subs (Bndr (IfaceTvBndr (n, t)) argf) - = Bndr (IfaceTvBndr (n, go subs t)) argf - - go_args :: FastStringEnv IfaceType -> IfaceAppArgs -> IfaceAppArgs - go_args _ IA_Nil = IA_Nil - go_args subs (IA_Arg ty argf args) - = IA_Arg (go subs ty) argf (go_args subs args) - - check_substitution :: IfaceType -> Maybe IfaceType - check_substitution (IfaceTyConApp tc _) - | def_rep - , tc `ifaceTyConHasKey` runtimeRepTyConKey - = Just liftedRep_ty - | def_rep - , tc `ifaceTyConHasKey` levityTyConKey - = Just lifted_ty - | def_mult - , tc `ifaceTyConHasKey` multiplicityTyConKey - = Just many_ty - check_substitution _ = Nothing - --- | The type ('BoxedRep 'Lifted), also known as LiftedRep. -liftedRep_ty :: IfaceType -liftedRep_ty = - IfaceTyConApp liftedRep IA_Nil - where - liftedRep :: IfaceTyCon - liftedRep = IfaceTyCon tc_name (mkIfaceTyConInfo NotPromoted IfaceNormalTyCon) - where tc_name = getName liftedRepTyCon - --- | The type 'Lifted :: Levity'. -lifted_ty :: IfaceType -lifted_ty = - IfaceTyConApp (IfaceTyCon dc_name (mkIfaceTyConInfo IsPromoted IfaceNormalTyCon)) - IA_Nil - where dc_name = getName liftedDataConTyCon - --- | The type 'Many :: Multiplicity'. -many_ty :: IfaceType -many_ty = - IfaceTyConApp (IfaceTyCon dc_name (mkIfaceTyConInfo IsPromoted IfaceNormalTyCon)) - IA_Nil - where dc_name = getName manyDataConTyCon - -hideNonStandardTypes :: (IfaceType -> SDoc) -> IfaceType -> SDoc -hideNonStandardTypes f ty - = sdocOption sdocPrintExplicitRuntimeReps $ \printExplicitRuntimeReps -> - sdocOption sdocLinearTypes $ \linearTypes -> - getPprStyle $ \sty -> - let def_rep = not printExplicitRuntimeReps - def_mult = not linearTypes - in if userStyle sty - then f (defaultIfaceTyVarsOfKind def_rep def_mult ty) - else f ty - -instance Outputable IfaceAppArgs where - ppr tca = pprIfaceAppArgs tca - -pprIfaceAppArgs, pprParendIfaceAppArgs :: IfaceAppArgs -> SDoc -pprIfaceAppArgs = ppr_app_args topPrec -pprParendIfaceAppArgs = ppr_app_args appPrec - -ppr_app_args :: PprPrec -> IfaceAppArgs -> SDoc -ppr_app_args ctx_prec = go - where - go :: IfaceAppArgs -> SDoc - go IA_Nil = empty - go (IA_Arg t argf ts) = ppr_app_arg ctx_prec (t, argf) <+> go ts - --- See Note [Pretty-printing invisible arguments] -ppr_app_arg :: PprPrec -> (IfaceType, ArgFlag) -> SDoc -ppr_app_arg ctx_prec (t, argf) = - sdocOption sdocPrintExplicitKinds $ \print_kinds -> - case argf of - Required -> ppr_ty ctx_prec t - Specified | print_kinds - -> char '@' <> ppr_ty appPrec t - Inferred | print_kinds - -> char '@' <> braces (ppr_ty topPrec t) - _ -> empty - -------------------- -pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc -pprIfaceForAllPart tvs ctxt sdoc - = ppr_iface_forall_part ShowForAllWhen tvs ctxt sdoc - --- | Like 'pprIfaceForAllPart', but always uses an explicit @forall@. -pprIfaceForAllPartMust :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc -pprIfaceForAllPartMust tvs ctxt sdoc - = ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc - -pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc -pprIfaceForAllCoPart tvs sdoc - = sep [ pprIfaceForAllCo tvs, sdoc ] - -ppr_iface_forall_part :: ShowForAllFlag - -> [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc -ppr_iface_forall_part show_forall tvs ctxt sdoc - = sep [ case show_forall of - ShowForAllMust -> pprIfaceForAll tvs - ShowForAllWhen -> pprUserIfaceForAll tvs - , pprIfaceContextArr ctxt - , sdoc] - --- | Render the "forall ... ." or "forall ... ->" bit of a type. -pprIfaceForAll :: [IfaceForAllBndr] -> SDoc -pprIfaceForAll [] = empty -pprIfaceForAll bndrs@(Bndr _ vis : _) - = sep [ add_separator (forAllLit <+> fsep docs) - , pprIfaceForAll bndrs' ] - where - (bndrs', docs) = ppr_itv_bndrs bndrs vis - - add_separator stuff = case vis of - Required -> stuff <+> arrow - _inv -> stuff <> dot - - --- | Render the ... in @(forall ... .)@ or @(forall ... ->)@. --- Returns both the list of not-yet-rendered binders and the doc. --- No anonymous binders here! -ppr_itv_bndrs :: [IfaceForAllBndr] - -> ArgFlag -- ^ visibility of the first binder in the list - -> ([IfaceForAllBndr], [SDoc]) -ppr_itv_bndrs all_bndrs@(bndr@(Bndr _ vis) : bndrs) vis1 - | vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in - (bndrs', pprIfaceForAllBndr bndr : doc) - | otherwise = (all_bndrs, []) -ppr_itv_bndrs [] _ = ([], []) - -pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc -pprIfaceForAllCo [] = empty -pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot - -pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc -pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs - -pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc -pprIfaceForAllBndr bndr = - case bndr of - Bndr (IfaceTvBndr tv) Inferred -> - braces $ pprIfaceTvBndr tv suppress_sig (UseBndrParens False) - Bndr (IfaceTvBndr tv) _ -> - pprIfaceTvBndr tv suppress_sig (UseBndrParens True) - Bndr (IfaceIdBndr idv) _ -> pprIfaceIdBndr idv - where - -- See Note [Suppressing binder signatures] - suppress_sig = SuppressBndrSig False - -pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc -pprIfaceForAllCoBndr (tv, kind_co) - = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co) - --- | Show forall flag --- --- Unconditionally show the forall quantifier with ('ShowForAllMust') --- or when ('ShowForAllWhen') the names used are free in the binder --- or when compiling with -fprint-explicit-foralls. -data ShowForAllFlag = ShowForAllMust | ShowForAllWhen - -pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc -pprIfaceSigmaType show_forall ty - = hideNonStandardTypes ppr_fn ty - where - ppr_fn iface_ty = - let (invis_tvs, theta, tau) = splitIfaceSigmaTy iface_ty - (req_tvs, tau') = splitIfaceReqForallTy tau - -- splitIfaceSigmaTy is recursive, so it will gather the binders after - -- the theta, i.e. forall a. theta => forall b. tau - -- will give you ([a,b], theta, tau). - -- - -- This isn't right when it comes to visible forall (see - -- testsuite/tests/polykinds/T18522-ppr), - -- so we split off required binders separately, - -- using splitIfaceReqForallTy. - -- - -- An alternative solution would be to make splitIfaceSigmaTy - -- non-recursive (see #18458). - -- Then it could handle both invisible and required binders, and - -- splitIfaceReqForallTy wouldn't be necessary here. - in ppr_iface_forall_part show_forall invis_tvs theta $ - sep [pprIfaceForAll req_tvs, ppr tau'] - -pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc -pprUserIfaceForAll tvs - = sdocOption sdocPrintExplicitForalls $ \print_foralls -> - -- See Note [When to print foralls] in this module. - ppWhen (any tv_has_kind_var tvs - || any tv_is_required tvs - || print_foralls) $ - pprIfaceForAll tvs - where - tv_has_kind_var (Bndr (IfaceTvBndr (_,kind)) _) - = not (ifTypeIsVarFree kind) - tv_has_kind_var _ = False - - tv_is_required = isVisibleArgFlag . binderArgFlag - -{- -Note [When to print foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We opt to explicitly pretty-print `forall`s if any of the following -criteria are met: - -1. -fprint-explicit-foralls is on. - -2. A bound type variable has a polymorphic kind. E.g., - - forall k (a::k). Proxy a -> Proxy a - - Since a's kind mentions a variable k, we print the foralls. - -3. A bound type variable is a visible argument (#14238). - Suppose we are printing the kind of: - - T :: forall k -> k -> Type - - The "forall k ->" notation means that this kind argument is required. - That is, it must be supplied at uses of T. E.g., - - f :: T (Type->Type) Monad -> Int - - So we print an explicit "T :: forall k -> k -> Type", - because omitting it and printing "T :: k -> Type" would be - utterly misleading. - - See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] - in GHC.Core.TyCo.Rep. - -N.B. Until now (Aug 2018) we didn't check anything for coercion variables. - -Note [Printing foralls in type family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use the same criteria as in Note [When to print foralls] to determine -whether a type family instance should be pretty-printed with an explicit -`forall`. Example: - - type family Foo (a :: k) :: k where - Foo Maybe = [] - Foo (a :: Type) = Int - Foo a = a - -Without -fprint-explicit-foralls enabled, this will be pretty-printed as: - -type family Foo (a :: k) :: k where - Foo Maybe = [] - Foo a = Int - forall k (a :: k). Foo a = a - -Note that only the third equation has an explicit forall, since it has a type -variable with a non-Type kind. (If -fprint-explicit-foralls were enabled, then -the second equation would be preceded with `forall a.`.) - -There is one tricky point in the implementation: what visibility -do we give the type variables in a type family instance? Type family instances -only store type *variables*, not type variable *binders*, and only the latter -has visibility information. We opt to default the visibility of each of these -type variables to Specified because users can't ever instantiate these -variables manually, so the choice of visibility is only relevant to -pretty-printing. (This is why the `k` in `forall k (a :: k). ...` above is -printed the way it is, even though it wasn't written explicitly in the -original source code.) - -We adopt the same strategy for data family instances. Example: - - data family DF (a :: k) - data instance DF '[a, b] = DFList - -That data family instance is pretty-printed as: - - data instance forall j (a :: j) (b :: j). DF '[a, b] = DFList - -This is despite that the representation tycon for this data instance (call it -$DF:List) actually has different visibilities for its binders. -However, the visibilities of these binders are utterly irrelevant to the -programmer, who cares only about the specificity of variables in `DF`'s type, -not $DF:List's type. Therefore, we opt to pretty-print all variables in data -family instances as Specified. - -Note [Printing promoted type constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this GHCi session (#14343) - > _ :: Proxy '[ 'True ] - error: - Found hole: _ :: Proxy '['True] - -This would be bad, because the '[' looks like a character literal. -Solution: in type-level lists and tuples, add a leading space -if the first type is itself promoted. See pprSpaceIfPromotedTyCon. --} - - -------------------- - --- | Prefix a space if the given 'IfaceType' is a promoted 'TyCon'. --- See Note [Printing promoted type constructors] -pprSpaceIfPromotedTyCon :: IfaceType -> SDoc -> SDoc -pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _) - = case ifaceTyConIsPromoted (ifaceTyConInfo tyCon) of - IsPromoted -> (space <>) - _ -> id -pprSpaceIfPromotedTyCon _ - = id - --- See equivalent function in "GHC.Core.TyCo.Rep" -pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc --- Given a type-level list (t1 ': t2), see if we can print --- it in list notation [t1, ...]. --- Precondition: Opt_PrintExplicitKinds is off -pprIfaceTyList ctxt_prec ty1 ty2 - = case gather ty2 of - (arg_tys, Nothing) - -> char '\'' <> brackets (pprSpaceIfPromotedTyCon ty1 (fsep - (punctuate comma (map (ppr_ty topPrec) (ty1:arg_tys))))) - (arg_tys, Just tl) - -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1) - 2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]]) - where - gather :: IfaceType -> ([IfaceType], Maybe IfaceType) - -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn] - -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl - gather (IfaceTyConApp tc tys) - | tc `ifaceTyConHasKey` consDataConKey - , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys - , isInvisibleArgFlag argf - , (args, tl) <- gather ty2 - = (ty1:args, tl) - | tc `ifaceTyConHasKey` nilDataConKey - = ([], Nothing) - gather ty = ([], Just ty) - -pprIfaceTypeApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc -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 -> - - 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 - -- NB: pprTuple requires a saturated tuple. - - | IfaceSumTyCon arity <- ifaceTyConSort info - , not debug - , arity == ifaceVisAppArgsLength tys - -> pprSum (ifaceTyConIsPromoted info) tys - -- NB: pprSum requires a saturated unboxed sum. - - | 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 - - | isIfaceTyConAppLiftedTypeKind tc tys - , 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_app_arg appPrec) $ - appArgsIfaceTypesArgFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) args) - -- Use appArgsIfaceTypesArgFlags to print invisible arguments - -- correctly (#19310) - - | tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey - , not debug - -- Suppress detail unless you _really_ want to see - -> text "(TypeError ...)" - - | Just doc <- ppr_equality ctxt_prec tc (appArgsIfaceTypes tys) - -> doc - - | otherwise - -> ppr_iface_tc_app ppr_app_arg ctxt_prec tc $ - appArgsIfaceTypesArgFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) tys - where - info = ifaceTyConInfo tc - -ppr_kind_type :: PprPrec -> SDoc -ppr_kind_type ctxt_prec = sdocOption sdocStarIsType $ \case - False -> pprPrefixOcc liftedTypeKindTyConName - True -> maybeParen ctxt_prec starPrec $ - unicodeSyntax (char '★') (char '*') - --- | Pretty-print a type-level equality. --- Returns (Just doc) if the argument is a /saturated/ application --- of eqTyCon (~) --- eqPrimTyCon (~#) --- eqReprPrimTyCon (~R#) --- heqTyCon (~~) --- --- See Note [Equality predicates in IfaceType] --- and Note [The equality types story] in GHC.Builtin.Types.Prim -ppr_equality :: PprPrec -> IfaceTyCon -> [IfaceType] -> Maybe SDoc -ppr_equality ctxt_prec tc args - | hetero_eq_tc - , [k1, k2, t1, t2] <- args - = Just $ print_equality (k1, k2, t1, t2) - - | hom_eq_tc - , [k, t1, t2] <- args - = Just $ print_equality (k, k, t1, t2) - - | otherwise - = Nothing - where - homogeneous = tc_name `hasKey` eqTyConKey -- (~) - || hetero_tc_used_homogeneously - where - hetero_tc_used_homogeneously - = case ifaceTyConSort $ ifaceTyConInfo tc of - IfaceEqualityTyCon -> True - _other -> False - -- True <=> a heterogeneous equality whose arguments - -- are (in this case) of the same kind - - tc_name = ifaceTyConName tc - pp = ppr_ty - hom_eq_tc = tc_name `hasKey` eqTyConKey -- (~) - hetero_eq_tc = tc_name `hasKey` eqPrimTyConKey -- (~#) - || tc_name `hasKey` eqReprPrimTyConKey -- (~R#) - || tc_name `hasKey` heqTyConKey -- (~~) - nominal_eq_tc = tc_name `hasKey` heqTyConKey -- (~~) - || tc_name `hasKey` eqPrimTyConKey -- (~#) - print_equality args = - sdocOption sdocPrintExplicitKinds $ \print_kinds -> - sdocOption sdocPrintEqualityRelations $ \print_eqs -> - getPprStyle $ \style -> - getPprDebug $ \debug -> - print_equality' args print_kinds - (print_eqs || dumpStyle style || debug) - - print_equality' (ki1, ki2, ty1, ty2) print_kinds print_eqs - | -- If -fprint-equality-relations is on, just print the original TyCon - print_eqs - = ppr_infix_eq (ppr tc) - - | -- Homogeneous use of heterogeneous equality (ty1 ~~ ty2) - -- or unlifted equality (ty1 ~# ty2) - nominal_eq_tc, homogeneous - = ppr_infix_eq (text "~") - - | -- Heterogeneous use of unlifted equality (ty1 ~# ty2) - not homogeneous - = ppr_infix_eq (ppr heqTyCon) - - | -- Homogeneous use of representational unlifted equality (ty1 ~R# ty2) - tc_name `hasKey` eqReprPrimTyConKey, homogeneous - = let ki | print_kinds = [pp appPrec ki1] - | otherwise = [] - in pprIfacePrefixApp ctxt_prec (ppr coercibleTyCon) - (ki ++ [pp appPrec ty1, pp appPrec ty2]) - - -- The other cases work as you'd expect - | otherwise - = ppr_infix_eq (ppr tc) - where - ppr_infix_eq :: SDoc -> SDoc - ppr_infix_eq eq_op = pprIfaceInfixApp ctxt_prec eq_op - (pp_ty_ki ty1 ki1) (pp_ty_ki ty2 ki2) - where - pp_ty_ki ty ki - | print_kinds - = parens (pp topPrec ty <+> dcolon <+> pp opPrec ki) - | otherwise - = pp opPrec ty - - -pprIfaceCoTcApp :: PprPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc -pprIfaceCoTcApp ctxt_prec tc tys = - ppr_iface_tc_app (\prec (co, _) -> ppr_co prec co) ctxt_prec tc - (map (, Required) tys) - -- We are trying to re-use ppr_iface_tc_app here, which requires its - -- arguments to be accompanied by visibilities. But visibility is - -- irrelevant when printing coercions, so just default everything to - -- Required. - --- | Pretty-prints an application of a type constructor to some arguments --- (whose visibilities are known). This is polymorphic (over @a@) since we use --- this function to pretty-print two different things: --- --- 1. Types (from `pprTyTcApp'`) --- --- 2. Coercions (from 'pprIfaceCoTcApp') -ppr_iface_tc_app :: (PprPrec -> (a, ArgFlag) -> SDoc) - -> PprPrec -> IfaceTyCon -> [(a, ArgFlag)] -> SDoc -ppr_iface_tc_app pp _ tc [ty] - | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp topPrec ty) - -ppr_iface_tc_app pp ctxt_prec tc tys - | tc `ifaceTyConHasKey` liftedTypeKindTyConKey - = ppr_kind_type ctxt_prec - - | not (isSymOcc (nameOccName (ifaceTyConName tc))) - = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys) - - | [ ty1@(_, Required) - , ty2@(_, Required) ] <- tys - -- Infix, two visible arguments (we know nothing of precedence though). - -- Don't apply this special case if one of the arguments is invisible, - -- lest we print something like (@LiftedRep -> @LiftedRep) (#15941). - = pprIfaceInfixApp ctxt_prec (ppr tc) - (pp opPrec ty1) (pp opPrec ty2) - - | otherwise - = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys) - --- | Pretty-print an unboxed sum type. The sum should be saturated: --- as many visible arguments as the arity of the sum. --- --- NB: this always strips off the invisible 'RuntimeRep' arguments, --- even with `-fprint-explicit-runtime-reps` and `-fprint-explicit-kinds`. -pprSum :: PromotionFlag -> IfaceAppArgs -> SDoc -pprSum is_promoted args - = -- drop the RuntimeRep vars. - -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon - let tys = appArgsIfaceTypes args - args' = drop (length tys `div` 2) tys - in pprPromotionQuoteI is_promoted - <> sumParens (pprWithBars (ppr_ty topPrec) args') - --- | Pretty-print a tuple type (boxed tuple, constraint tuple, unboxed tuple). --- The tuple should be saturated: as many visible arguments as the arity of --- the tuple. --- --- NB: this always strips off the invisible 'RuntimeRep' arguments, --- even with `-fprint-explicit-runtime-reps` and `-fprint-explicit-kinds`. -pprTuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc -pprTuple ctxt_prec sort promoted args = - case promoted of - IsPromoted - -> let tys = appArgsIfaceTypes args - args' = drop (length tys `div` 2) tys - spaceIfPromoted = case args' of - arg0:_ -> pprSpaceIfPromotedTyCon arg0 - _ -> id - in ppr_tuple_app args' $ - pprPromotionQuoteI IsPromoted <> - tupleParens sort (spaceIfPromoted (pprWithCommas pprIfaceType args')) - - NotPromoted - | ConstraintTuple <- sort - , IA_Nil <- args - -> maybeParen ctxt_prec sigPrec $ - text "() :: Constraint" - - | otherwise - -> -- drop the RuntimeRep vars. - -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon - let tys = appArgsIfaceTypes args - args' = case sort of - UnboxedTuple -> drop (length tys `div` 2) tys - _ -> tys - in - ppr_tuple_app args' $ - pprPromotionQuoteI promoted <> - tupleParens sort (pprWithCommas pprIfaceType args') - where - ppr_tuple_app :: [IfaceType] -> SDoc -> SDoc - ppr_tuple_app args_wo_runtime_reps ppr_args_w_parens - -- Special-case unary boxed tuples so that they are pretty-printed as - -- `Solo x`, not `(x)` - | [_] <- args_wo_runtime_reps - , BoxedTuple <- sort - = let unit_tc_info = mkIfaceTyConInfo promoted IfaceNormalTyCon - unit_tc = IfaceTyCon (tupleTyConName sort 1) unit_tc_info in - pprPrecIfaceType ctxt_prec $ IfaceTyConApp unit_tc args - | otherwise - = ppr_args_w_parens - -pprIfaceTyLit :: IfaceTyLit -> SDoc -pprIfaceTyLit (IfaceNumTyLit n) = integer n -pprIfaceTyLit (IfaceStrTyLit n) = text (show n) -pprIfaceTyLit (IfaceCharTyLit c) = text (show c) - -pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc -pprIfaceCoercion = ppr_co topPrec -pprParendIfaceCoercion = ppr_co appPrec - -ppr_co :: PprPrec -> IfaceCoercion -> SDoc -ppr_co _ (IfaceReflCo ty) = angleBrackets (ppr ty) <> ppr_role Nominal -ppr_co _ (IfaceGReflCo r ty IfaceMRefl) - = angleBrackets (ppr ty) <> ppr_role r -ppr_co ctxt_prec (IfaceGReflCo r ty (IfaceMCo co)) - = ppr_special_co ctxt_prec - (text "GRefl" <+> ppr r <+> pprParendIfaceType ty) [co] -ppr_co ctxt_prec (IfaceFunCo r cow co1 co2) - = maybeParen ctxt_prec funPrec $ - sep (ppr_co funPrec co1 : ppr_fun_tail cow co2) - where - ppr_fun_tail cow' (IfaceFunCo r cow co1 co2) - = (coercionArrow cow' <> ppr_role r <+> ppr_co funPrec co1) : ppr_fun_tail cow co2 - ppr_fun_tail cow' other_co - = [coercionArrow cow' <> ppr_role r <+> pprIfaceCoercion other_co] - coercionArrow w = mulArrow (ppr_co topPrec w) - -ppr_co _ (IfaceTyConAppCo r tc cos) - = parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r -ppr_co ctxt_prec (IfaceAppCo co1 co2) - = maybeParen ctxt_prec appPrec $ - ppr_co funPrec co1 <+> pprParendIfaceCoercion co2 -ppr_co ctxt_prec co@(IfaceForAllCo {}) - = maybeParen ctxt_prec funPrec $ - pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co) - where - (tvs, inner_co) = split_co co - - split_co (IfaceForAllCo (IfaceTvBndr (name, _)) kind_co co') - = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') - split_co (IfaceForAllCo (IfaceIdBndr (_, name, _)) kind_co co') - = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') - split_co co' = ([], co') - --- Why these three? See Note [Free tyvars in IfaceType] -ppr_co _ (IfaceFreeCoVar covar) = ppr covar -ppr_co _ (IfaceCoVarCo covar) = ppr covar -ppr_co _ (IfaceHoleCo covar) = braces (ppr covar) - -ppr_co _ (IfaceUnivCo prov role ty1 ty2) - = text "Univ" <> (parens $ - sep [ ppr role <+> pprIfaceUnivCoProv prov - , dcolon <+> ppr ty1 <> comma <+> ppr ty2 ]) - -ppr_co ctxt_prec (IfaceInstCo co ty) - = maybeParen ctxt_prec appPrec $ - text "Inst" <+> pprParendIfaceCoercion co - <+> pprParendIfaceCoercion ty - -ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos) - = maybeParen ctxt_prec appPrec $ ppr tc <+> parens (interpp'SP cos) - -ppr_co ctxt_prec (IfaceAxiomInstCo n i cos) - = ppr_special_co ctxt_prec (ppr n <> brackets (ppr i)) cos -ppr_co ctxt_prec (IfaceSymCo co) - = ppr_special_co ctxt_prec (text "Sym") [co] -ppr_co ctxt_prec (IfaceTransCo co1 co2) - -- chain nested TransCo - = let ppr_trans (IfaceTransCo c1 c2) = semi <+> ppr_co topPrec c1 : ppr_trans c2 - ppr_trans c = [semi <+> ppr_co opPrec c] - in maybeParen ctxt_prec opPrec $ - vcat (ppr_co topPrec co1 : ppr_trans co2) -ppr_co ctxt_prec (IfaceNthCo d co) - = ppr_special_co ctxt_prec (text "Nth:" <> int d) [co] -ppr_co ctxt_prec (IfaceLRCo lr co) - = ppr_special_co ctxt_prec (ppr lr) [co] -ppr_co ctxt_prec (IfaceSubCo co) - = ppr_special_co ctxt_prec (text "Sub") [co] -ppr_co ctxt_prec (IfaceKindCo co) - = ppr_special_co ctxt_prec (text "Kind") [co] - -ppr_special_co :: PprPrec -> SDoc -> [IfaceCoercion] -> SDoc -ppr_special_co ctxt_prec doc cos - = maybeParen ctxt_prec appPrec - (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))]) - -ppr_role :: Role -> SDoc -ppr_role r = underscore <> pp_role - where pp_role = case r of - Nominal -> char 'N' - Representational -> char 'R' - Phantom -> char 'P' - ------------------- -pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc -pprIfaceUnivCoProv (IfacePhantomProv co) - = text "phantom" <+> pprParendIfaceCoercion co -pprIfaceUnivCoProv (IfaceProofIrrelProv co) - = text "irrel" <+> pprParendIfaceCoercion co -pprIfaceUnivCoProv (IfacePluginProv s) - = text "plugin" <+> doubleQuotes (text s) -pprIfaceUnivCoProv (IfaceCorePrepProv _) - = text "CorePrep" - -------------------- -instance Outputable IfaceTyCon where - ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc) - -instance Outputable IfaceTyConInfo where - ppr (IfaceTyConInfo { ifaceTyConIsPromoted = prom - , ifaceTyConSort = sort }) - = angleBrackets $ ppr prom <> comma <+> ppr sort - -pprPromotionQuote :: IfaceTyCon -> SDoc -pprPromotionQuote tc = - pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc - -pprPromotionQuoteI :: PromotionFlag -> SDoc -pprPromotionQuoteI NotPromoted = empty -pprPromotionQuoteI IsPromoted = char '\'' - -instance Outputable IfaceCoercion where - ppr = pprIfaceCoercion - instance Binary IfaceTyCon where put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i @@ -1843,9 +777,6 @@ instance Binary IfaceTyConInfo where get bh = mkIfaceTyConInfo <$> get bh <*> get bh -instance Outputable IfaceTyLit where - ppr = pprIfaceTyLit - instance Binary IfaceTyLit where put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n @@ -1879,62 +810,8 @@ instance Binary IfaceAppArgs where 1 -> return IA_Nil _ -> panic ("get IfaceAppArgs " ++ show c) -------------------- - --- Some notes about printing contexts --- --- In the event that we are printing a singleton context (e.g. @Eq a@) we can --- omit parentheses. However, we must take care to set the precedence correctly --- to opPrec, since something like @a :~: b@ must be parenthesized (see --- #9658). --- --- When printing a larger context we use 'fsep' instead of 'sep' so that --- the context doesn't get displayed as a giant column. Rather than, --- instance (Eq a, --- Eq b, --- Eq c, --- Eq d, --- Eq e, --- Eq f, --- Eq g, --- Eq h, --- Eq i, --- Eq j, --- Eq k, --- Eq l) => --- Eq (a, b, c, d, e, f, g, h, i, j, k, l) --- --- we want --- --- instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, --- Eq j, Eq k, Eq l) => --- Eq (a, b, c, d, e, f, g, h, i, j, k, l) - - - --- | Prints "(C a, D b) =>", including the arrow. --- Used when we want to print a context in a type, so we --- use 'funPrec' to decide whether to parenthesise a singleton --- predicate; e.g. Num a => a -> a -pprIfaceContextArr :: [IfacePredType] -> SDoc -pprIfaceContextArr [] = empty -pprIfaceContextArr [pred] = ppr_ty funPrec pred <+> darrow -pprIfaceContextArr preds = ppr_parend_preds preds <+> darrow - --- | Prints a context or @()@ if empty --- You give it the context precedence -pprIfaceContext :: PprPrec -> [IfacePredType] -> SDoc -pprIfaceContext _ [] = text "()" -pprIfaceContext prec [pred] = ppr_ty prec pred -pprIfaceContext _ preds = ppr_parend_preds preds - -ppr_parend_preds :: [IfacePredType] -> SDoc -ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds))) - instance Binary IfaceType where - put_ _ (IfaceFreeTyVar tv) - = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv) - + put_ _ (XIfaceType x) = dataConCantHappen x put_ bh (IfaceForAllTy aa ab) = do putByte bh 0 put_ bh aa @@ -2007,6 +884,7 @@ instance Binary IfaceMCoercion where _ -> panic ("get IfaceMCoercion " ++ show tag) instance Binary IfaceCoercion where + put_ _ (XIfaceCoercion x) = dataConCantHappen x put_ bh (IfaceReflCo a) = do putByte bh 1 put_ bh a @@ -2078,11 +956,6 @@ instance Binary IfaceCoercion where putByte bh 17 put_ bh a put_ bh b - put_ _ (IfaceFreeCoVar cv) - = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv) - put_ _ (IfaceHoleCo cv) - = pprPanic "Can't serialise IfaceHoleCo" (ppr cv) - -- See Note [Holes in IfaceCoercion] get bh = do tag <- getByte bh @@ -2180,9 +1053,9 @@ instance Binary (DefMethSpec IfaceType) where 0 -> return VanillaDM _ -> do { t <- get bh; return (GenericDM t) } -instance NFData IfaceType where +instance (NFData (XXIfaceType p), NFData (XXIfaceCoercion p)) => NFData (IfaceType' p) where rnf = \case - IfaceFreeTyVar f1 -> f1 `seq` () + XIfaceType f1 -> rnf f1 IfaceTyVar f1 -> rnf f1 IfaceLitTy f1 -> rnf f1 IfaceAppTy f1 f2 -> rnf f1 `seq` rnf f2 @@ -2199,8 +1072,9 @@ instance NFData IfaceTyLit where IfaceStrTyLit f1 -> rnf f1 IfaceCharTyLit f1 -> rnf f1 -instance NFData IfaceCoercion where +instance (NFData (XXIfaceType p), NFData (XXIfaceCoercion p)) => NFData (IfaceCoercion' p) where rnf = \case + XIfaceCoercion f1 -> rnf f1 IfaceReflCo f1 -> rnf f1 IfaceGReflCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 IfaceFunCo f1 f2 f3 f4 -> f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 @@ -2218,13 +1092,11 @@ instance NFData IfaceCoercion where IfaceInstCo f1 f2 -> rnf f1 `seq` rnf f2 IfaceKindCo f1 -> rnf f1 IfaceSubCo f1 -> rnf f1 - IfaceFreeCoVar f1 -> f1 `seq` () - IfaceHoleCo f1 -> f1 `seq` () -instance NFData IfaceUnivCoProv where +instance NFData (IfaceUnivCoProv' p) where rnf x = seq x () -instance NFData IfaceMCoercion where +instance NFData (XXIfaceType p) => NFData (IfaceMCoercion' p) where rnf x = seq x () instance NFData IfaceOneShot where @@ -2248,7 +1120,10 @@ instance NFData IfaceBndr where IfaceIdBndr id_bndr -> rnf id_bndr IfaceTvBndr tv_bndr -> rnf tv_bndr -instance NFData IfaceAppArgs where +instance (NFData (XXIfaceType p), NFData (XXIfaceCoercion p)) => NFData (IfaceAppArgs' p) where rnf = \case IA_Nil -> () IA_Arg f1 f2 f3 -> rnf f1 `seq` f2 `seq` rnf f3 + +instance NFData IfaceUnivCoProv where + rnf x = seq x () diff --git a/compiler/GHC/Iface/Type.hs-boot b/compiler/GHC/Iface/Type.hs-boot index 9c10f29ed5..13e91b78f1 100644 --- a/compiler/GHC/Iface/Type.hs-boot +++ b/compiler/GHC/Iface/Type.hs-boot @@ -8,10 +8,17 @@ where -- See Note [Depend on GHC.Num.Integer] in GHC.Base import GHC.Base () -data IfaceAppArgs +data IfaceType' p +data IfaceAppArgs' p +data IfaceBndr' p +data IfaceCoercion' p -data IfaceType data IfaceTyCon data IfaceTyLit -data IfaceCoercion -data IfaceBndr + +data TtgIface + +type IfaceType = IfaceType' TtgIface +type IfaceAppArgs = IfaceAppArgs' TtgIface +type IfaceBndr = IfaceBndr' TtgIface +type IfaceCoercion = IfaceCoercion' TtgIface diff --git a/compiler/GHC/Iface/Type/Ppr.hs b/compiler/GHC/Iface/Type/Ppr.hs new file mode 100644 index 0000000000..5aec9ca53f --- /dev/null +++ b/compiler/GHC/Iface/Type/Ppr.hs @@ -0,0 +1,1399 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + +This module defines interface types and binders +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + -- FlexibleInstances for Binary (DefMethSpec IfaceType) +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} + +-- For NFData instance +{-# LANGUAGE UndecidableInstances #-} + +-- | Printing Iface's Type +module GHC.Iface.Type.Ppr ( + + IfaceTypePpr, IfaceKindPpr, + IfaceContextPpr, IfacePredTypePpr, + IfaceCoercionPpr,IfaceMCoercionPpr, + IfaceUnivCoProvPpr, + IfaceMultPpr, + IfaceAppArgsPpr, + IfaceBndrPpr, + IfaceTvBndrPpr, IfaceIdBndrPpr, + IfaceTyConBinderPpr, IfaceForAllBndrPpr, IfaceForAllSpecBndrPpr, + + ShowForAllFlag(..), + + SuppressBndrSig(..), + UseBndrParens(..), + PrintExplicitKinds(..), + pprIfaceType, pprParendIfaceType, pprPrecIfaceType, + pprIfaceContext, pprIfaceContextArr, + pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders, + pprIfaceBndrs, pprIfaceAppArgs, pprParendIfaceAppArgs, + pprIfaceForAllPart, pprIfaceForAllPartMust, pprIfaceForAll, + pprIfaceSigmaType, pprIfaceTyLit, + pprIfaceCoercion, pprParendIfaceCoercion, + pprIfaceTypeApp, pprUserIfaceForAll, + pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp, + ppr_fun_arrow, + isIfaceTauType, + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Builtin.Types + ( coercibleTyCon, heqTyCon + , tupleTyConName + , manyDataConTyCon, oneDataConTyCon + , liftedRepTyCon, liftedDataConTyCon ) +import {-# SOURCE #-} GHC.Core.Type ( isRuntimeRepTy, isMultiplicityTy, isLevityTy ) + +import GHC.Core.TyCon hiding ( pprPromotionQuote ) +import GHC.Types.Var +import GHC.Builtin.Names +import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKindTyConName ) +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Utils.Outputable +import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isMetaTyVar, isTyConableTyVar ) +import GHC.Iface.Type + +import Control.DeepSeq + +{- +************************************************************************ +* * + Local (nested) binders +* * +************************************************************************ +-} + +type IfaceIdBndrPpr = IfaceIdBndr' TtgIfacePpr +type IfaceTvBndrPpr = IfaceTvBndr' TtgIfacePpr + +type IfaceBndrPpr = IfaceBndr' TtgIfacePpr + +type IfaceLamBndrPpr = (IfaceBndrPpr, IfaceOneShot) + +{- +%************************************************************************ +%* * + IfaceType +%* * +%************************************************************************ +-} + +type IfaceKindPpr = IfaceKind' TtgIfacePpr +type IfaceMultPpr = IfaceMult' TtgIfacePpr + +-- See Note [Free tyvars in IfaceType] +newtype IfaceFreeTyVar = IfaceFreeTyVar TyVar + +data IfaceFreeCoVar + = IfaceFreeCoVar CoVar -- See Note [Free tyvars in IfaceType] + | IfaceHoleCo CoVar -- ^ See Note [Holes in (IfaceCoercion' p)] + +instance NFData IfaceFreeTyVar where + rnf = \case + IfaceFreeTyVar f1 -> f1 `seq` () + +instance NFData IfaceFreeCoVar where + rnf = \case + IfaceFreeCoVar f1 -> f1 `seq` () + IfaceHoleCo f1 -> f1 `seq` () + +data TtgIfacePpr + +type instance XXIfaceType TtgIfacePpr = IfaceFreeTyVar +type IfaceTypePpr = IfaceType' TtgIfacePpr + +type instance XXIfaceCoercion TtgIfacePpr = IfaceFreeCoVar + +type IfacePredTypePpr = IfacePredType' TtgIfacePpr +type IfaceContextPpr = IfaceContext' TtgIfacePpr + +type IfaceTyConBinderPpr = IfaceTyConBinder' TtgIfacePpr +type IfaceForAllBndrPpr = IfaceForAllBndr' TtgIfacePpr +type IfaceForAllSpecBndrPpr = IfaceForAllSpecBndr' TtgIfacePpr + +type IfaceAppArgsPpr = IfaceAppArgs' TtgIfacePpr + +{- Note [Free tyvars in IfaceType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to +an IfaceType and pretty printing that. This eliminates a lot of +pretty-print duplication, and it matches what we do with pretty- +printing TyThings. See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr. + +It works fine for closed types, but when printing debug traces (e.g. +when using -ddump-tc-trace) we print a lot of /open/ types. These +types are full of TcTyVars, and it's absolutely crucial to print them +in their full glory, with their unique, TcTyVarDetails etc. + +So we simply embed a TyVar in IfaceType with the IfaceFreeTyVar constructor. +Note that: + +* We never expect to serialise an IfaceFreeTyVar into an interface file, nor + to deserialise one. IfaceFreeTyVar is used only in the "convert to IfaceType + and then pretty-print" pipeline. + +We do the same for covars, naturally. + +Note [Equality predicates in IfaceType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC has several varieties of type equality (see Note [The equality types story] +in GHC.Builtin.Types.Prim for details). In an effort to avoid confusing users, we suppress +the differences during pretty printing unless certain flags are enabled. +Here is how each equality predicate* is printed in homogeneous and +heterogeneous contexts, depending on which combination of the +-fprint-explicit-kinds and -fprint-equality-relations flags is used: + +-------------------------------------------------------------------------------------------- +| Predicate | Neither flag | -fprint-explicit-kinds | +|-------------------------------|----------------------------|-----------------------------| +| a ~ b (homogeneous) | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~~ b, homogeneously | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~~ b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | +| a ~# b, homogeneously | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~# b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | +| Coercible a b (homogeneous) | Coercible a b | Coercible @Type a b | +| a ~R# b, homogeneously | Coercible a b | Coercible @Type a b | +| a ~R# b, heterogeneously | a ~R# b | (a :: Type) ~R# (c :: k) | +|-------------------------------|----------------------------|-----------------------------| +| Predicate | -fprint-equality-relations | Both flags | +|-------------------------------|----------------------------|-----------------------------| +| a ~ b (homogeneous) | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~~ b, homogeneously | a ~~ b | (a :: Type) ~~ (b :: Type) | +| a ~~ b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | +| a ~# b, homogeneously | a ~# b | (a :: Type) ~# (b :: Type) | +| a ~# b, heterogeneously | a ~# c | (a :: Type) ~# (c :: k) | +| Coercible a b (homogeneous) | Coercible a b | Coercible @Type a b | +| a ~R# b, homogeneously | a ~R# b | (a :: Type) ~R# (b :: Type) | +| a ~R# b, heterogeneously | a ~R# b | (a :: Type) ~R# (c :: k) | +-------------------------------------------------------------------------------------------- + +(* There is no heterogeneous, representational, lifted equality counterpart +to (~~). There could be, but there seems to be no use for it.) + +This table adheres to the following rules: + +A. With -fprint-equality-relations, print the true equality relation. +B. Without -fprint-equality-relations: + i. If the equality is representational and homogeneous, use Coercible. + ii. Otherwise, if the equality is representational, use ~R#. + iii. If the equality is nominal and homogeneous, use ~. + iv. Otherwise, if the equality is nominal, use ~~. +C. With -fprint-explicit-kinds, print kinds on both sides of an infix operator, + as above; or print the kind with Coercible. +D. Without -fprint-explicit-kinds, don't print kinds. + +A hetero-kinded equality is used homogeneously when it is applied to two +identical kinds. Unfortunately, determining this from an IfaceType isn't +possible since we can't see through type synonyms. Consequently, we need to +record whether this particular application is homogeneous in IfaceTyConSort +for the purposes of pretty-printing. + +See Note [The equality types story] in GHC.Builtin.Types.Prim. +-} + +type IfaceMCoercionPpr = IfaceMCoercion' TtgIfacePpr +type IfaceCoercionPpr = IfaceCoercion' TtgIfacePpr +type IfaceUnivCoProvPpr = IfaceUnivCoProv' TtgIfacePpr + +{- +%************************************************************************ +%* * + Functions over IFaceTypes +* * +************************************************************************ +-} + +ifTypeIsVarFree :: IfaceTypePpr -> Bool +-- Returns True if the type definitely has no variables at all +-- Just used to control pretty printing +ifTypeIsVarFree ty = go ty + where + go (IfaceTyVar {}) = False + go (XIfaceType _) = False + go (IfaceAppTy fun args) = go fun && go_args args + go (IfaceFunTy _ w arg res) = go w && go arg && go res + go (IfaceForAllTy {}) = False + go (IfaceTyConApp _ args) = go_args args + go (IfaceTupleTy _ _ args) = go_args args + go (IfaceLitTy _) = True + go (IfaceCastTy {}) = False -- Safe + go (IfaceCoercionTy {}) = False -- Safe + + go_args IA_Nil = True + go_args (IA_Arg arg _ args) = go arg && go_args args + +{- +Note [Suppressing invisible arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use the IfaceAppArgs data type to specify which of the arguments to a type +should be displayed when pretty-printing, under the control of +-fprint-explicit-kinds. +See also Type.filterOutInvisibleTypes. +For example, given + + T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism + 'Just :: forall k. k -> 'Maybe k -- Promoted + +we want + + T * Tree Int prints as T Tree Int + 'Just * prints as Just * + +For type constructors (IfaceTyConApp), IfaceAppArgs is a quite natural fit, +since the corresponding Core constructor: + + data Type + = ... + | TyConApp TyCon [Type] + +Already puts all of its arguments into a list. So when converting a Type to an +IfaceType (see toIfaceAppArgsX in GHC.Core.ToIface), we simply use the kind of +the TyCon (which is cached) to guide the process of converting the argument +Types into an IfaceAppArgs list. + +We also want this behavior for IfaceAppTy, since given: + + data Proxy (a :: k) + f :: forall (t :: forall a. a -> Type). Proxy Type (t Bool True) + +We want to print the return type as `Proxy (t True)` without the use of +-fprint-explicit-kinds (#15330). Accomplishing this is trickier than in the +tycon case, because the corresponding Core constructor for IfaceAppTy: + + data Type + = ... + | AppTy Type Type + +Only stores one argument at a time. Therefore, when converting an AppTy to an +IfaceAppTy (in toIfaceTypeX in GHC.CoreToIface), we: + +1. Flatten the chain of AppTys down as much as possible +2. Use typeKind to determine the function Type's kind +3. Use this kind to guide the process of converting the argument Types into an + IfaceAppArgs list. + +By flattening the arguments like this, we obtain two benefits: + +(a) We can reuse the same machinery to pretty-print IfaceTyConApp arguments as + we do IfaceTyApp arguments, which means that we only need to implement the + logic to filter out invisible arguments once. +(b) Unlike for tycons, finding the kind of a type in general (through typeKind) + is not a constant-time operation, so by flattening the arguments first, we + decrease the number of times we have to call typeKind. + +Note [Pretty-printing invisible arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Suppressing invisible arguments] is all about how to avoid printing +invisible arguments when the -fprint-explicit-kinds flag is disables. Well, +what about when it's enabled? Then we can and should print invisible kind +arguments, and this Note explains how we do it. + +As two running examples, consider the following code: + + {-# LANGUAGE PolyKinds #-} + data T1 a + data T2 (a :: k) + +When displaying these types (with -fprint-explicit-kinds on), we could just +do the following: + + T1 k a + T2 k a + +That certainly gets the job done. But it lacks a crucial piece of information: +is the `k` argument inferred or specified? To communicate this, we use visible +kind application syntax to distinguish the two cases: + + T1 @{k} a + T2 @k a + +Here, @{k} indicates that `k` is an inferred argument, and @k indicates that +`k` is a specified argument. (See +Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep for +a lengthier explanation on what "inferred" and "specified" mean.) + +************************************************************************ +* * + Pretty-printing +* * +************************************************************************ +-} + +if_print_coercions :: SDoc -- ^ if printing coercions + -> SDoc -- ^ otherwise + -> SDoc +if_print_coercions yes no + = sdocOption sdocPrintExplicitCoercions $ \print_co -> + getPprStyle $ \style -> + getPprDebug $ \debug -> + if print_co || dumpStyle style || debug + then yes + else no + +pprIfaceInfixApp :: PprPrec -> SDoc -> SDoc -> SDoc -> SDoc +pprIfaceInfixApp ctxt_prec pp_tc pp_ty1 pp_ty2 + = maybeParen ctxt_prec opPrec $ + sep [pp_ty1, pp_tc <+> pp_ty2] + +pprIfacePrefixApp :: PprPrec -> SDoc -> [SDoc] -> SDoc +pprIfacePrefixApp ctxt_prec pp_fun pp_tys + | null pp_tys = pp_fun + | otherwise = maybeParen ctxt_prec appPrec $ + hang pp_fun 2 (sep pp_tys) + +isIfaceTauType :: IfaceType -> Bool +isIfaceTauType (IfaceForAllTy _ _) = False +isIfaceTauType (IfaceFunTy InvisArg _ _ _) = False +isIfaceTauType _ = True + +-- ----------------------------- Printing binders ------------------------------------ + +instance Outputable IfaceBndrPpr where + ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr + ppr (IfaceTvBndr bndr) = char '@' <> pprIfaceTvBndr bndr (SuppressBndrSig False) + (UseBndrParens False) + +pprIfaceBndrs :: [IfaceBndrPpr] -> SDoc +pprIfaceBndrs bs = sep (map ppr bs) + +pprIfaceLamBndr :: IfaceLamBndrPpr -> SDoc +pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b +pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]" + +pprIfaceIdBndr :: IfaceIdBndrPpr -> SDoc +pprIfaceIdBndr (w, name, ty) = parens (ppr name <> brackets (ppr w) <+> dcolon <+> ppr ty) + +{- Note [Suppressing binder signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When printing the binders in a 'forall', we want to keep the kind annotations: + + forall (a :: k). blah + ^^^^ + good + +On the other hand, when we print the binders of a data declaration in :info, +the kind information would be redundant due to the standalone kind signature: + + type F :: Symbol -> Type + type F (s :: Symbol) = blah + ^^^^^^^^^ + redundant + +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 representation 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? +-- See Note [Suppressing binder signatures] +newtype SuppressBndrSig = SuppressBndrSig Bool + +newtype UseBndrParens = UseBndrParens Bool + +pprIfaceTvBndr :: IfaceTvBndrPpr -> SuppressBndrSig -> UseBndrParens -> SDoc +pprIfaceTvBndr (tv, ki) (SuppressBndrSig suppress_sig) (UseBndrParens use_parens) + | suppress_sig = ppr tv + | isIfaceLiftedTypeKind ki = ppr tv + | otherwise = maybe_parens (ppr tv <+> dcolon <+> ppr ki) + where + maybe_parens | use_parens = parens + | otherwise = id + +pprIfaceTyConBinders :: SuppressBndrSig -> [IfaceTyConBinderPpr] -> SDoc +pprIfaceTyConBinders suppress_sig = sep . map go + where + go :: IfaceTyConBinderPpr -> SDoc + go (Bndr (IfaceIdBndr bndr) _) = pprIfaceIdBndr bndr + go (Bndr (IfaceTvBndr bndr) vis) = + -- See Note [Pretty-printing invisible arguments] + case vis of + AnonTCB VisArg -> ppr_bndr (UseBndrParens True) + AnonTCB InvisArg -> char '@' <> braces (ppr_bndr (UseBndrParens False)) + -- The above case is rare. (See Note [AnonTCB InvisArg] in GHC.Core.TyCon.) + -- Should we print these differently? + NamedTCB Required -> ppr_bndr (UseBndrParens True) + NamedTCB Specified -> char '@' <> ppr_bndr (UseBndrParens True) + NamedTCB Inferred -> char '@' <> braces (ppr_bndr (UseBndrParens False)) + where + ppr_bndr = pprIfaceTvBndr bndr suppress_sig + +-- ----------------------------- Printing IfaceType ------------------------------------ + +--------------------------------- +instance Outputable IfaceTypePpr where + ppr ty = pprIfaceType ty + +pprIfaceType, pprParendIfaceType :: IfaceTypePpr -> SDoc +pprIfaceType = pprPrecIfaceType topPrec +pprParendIfaceType = pprPrecIfaceType appPrec + +pprPrecIfaceType :: PprPrec -> IfaceTypePpr -> SDoc +-- We still need `hideNonStandardTypes`, since the `pprPrecIfaceType` may be +-- called from other places, besides `:type` and `:info`. +pprPrecIfaceType prec ty = + hideNonStandardTypes (ppr_ty prec) ty + +ppr_fun_arrow :: IfaceMultPpr -> SDoc +ppr_fun_arrow w + | (IfaceTyConApp tc _) <- w + , tc `ifaceTyConHasKey` (getUnique manyDataConTyCon) = arrow + | (IfaceTyConApp tc _) <- w + , tc `ifaceTyConHasKey` (getUnique oneDataConTyCon) = lollipop + | otherwise = mulArrow (pprIfaceType w) + +ppr_sigma :: PprPrec -> IfaceTypePpr -> SDoc +ppr_sigma ctxt_prec ty + = maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty) + +ppr_ty :: PprPrec -> IfaceTypePpr -> SDoc +ppr_ty ctxt_prec ty@(IfaceForAllTy {}) = ppr_sigma ctxt_prec ty +ppr_ty ctxt_prec ty@(IfaceFunTy InvisArg _ _ _) = ppr_sigma ctxt_prec ty + +ppr_ty _ (XIfaceType (IfaceFreeTyVar tyvar)) = ppr tyvar -- This is the main reason for XIfaceFreeTyVar! +ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [Free tyvars in IfaceType] +ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys +ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys -- always fully saturated +ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n + -- Function types +ppr_ty ctxt_prec (IfaceFunTy _ w ty1 ty2) -- Should be VisArg + = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. + maybeParen ctxt_prec funPrec $ + sep [ppr_ty funPrec ty1, sep (ppr_fun_tail w ty2)] + where + ppr_fun_tail wthis (IfaceFunTy VisArg wnext ty1 ty2) + = (ppr_fun_arrow wthis <+> ppr_ty funPrec ty1) : ppr_fun_tail wnext ty2 + ppr_fun_tail wthis other_ty + = [ppr_fun_arrow wthis <+> pprIfaceType other_ty] + +ppr_ty ctxt_prec (IfaceAppTy t ts) + = if_print_coercions + ppr_app_ty + ppr_app_ty_no_casts + where + ppr_app_ty = + sdocOption sdocPrintExplicitKinds $ \print_kinds -> + let tys_wo_kinds = appArgsIfaceTypesArgFlags $ stripInvisArgs + (PrintExplicitKinds print_kinds) ts + in pprIfacePrefixApp ctxt_prec + (ppr_ty funPrec t) + (map (ppr_app_arg appPrec) tys_wo_kinds) + + + -- Strip any casts from the head of the application + ppr_app_ty_no_casts = + case t of + IfaceCastTy head _ -> ppr_ty ctxt_prec (mk_app_tys head ts) + _ -> ppr_app_ty + + mk_app_tys :: IfaceTypePpr -> IfaceAppArgsPpr -> IfaceTypePpr + mk_app_tys (IfaceTyConApp tc tys1) tys2 = + IfaceTyConApp tc (tys1 `mappend` tys2) + mk_app_tys t1 tys2 = IfaceAppTy t1 tys2 + +ppr_ty ctxt_prec (IfaceCastTy ty co) + = if_print_coercions + (parens (ppr_ty topPrec ty <+> text "|>" <+> ppr co)) + (ppr_ty ctxt_prec ty) + +ppr_ty ctxt_prec (IfaceCoercionTy co) + = if_print_coercions + (ppr_co ctxt_prec co) + (text "<>") + +{- Note [Defaulting RuntimeRep variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +RuntimeRep variables are considered by many (most?) users to be little +more than syntactic noise. When the notion was introduced there was a +significant and understandable push-back from those with pedagogy in +mind, which argued that RuntimeRep variables would throw a wrench into +nearly any teach approach since they appear in even the lowly ($) +function's type, + + ($) :: forall (w :: RuntimeRep) a (b :: TYPE w). (a -> b) -> a -> b + +which is significantly less readable than its non RuntimeRep-polymorphic type of + + ($) :: (a -> b) -> a -> b + +Moreover, unboxed types don't appear all that often in run-of-the-mill +Haskell programs, so it makes little sense to make all users pay this +syntactic overhead. + +For this reason it was decided that we would hide RuntimeRep variables +for now (see #11549). We do this by defaulting all type variables of +kind RuntimeRep to LiftedRep. +Likewise, we default all Multiplicity variables to Many. + +This is done in a pass right before pretty-printing +(defaultIfaceTyVarsOfKind, controlled by +-fprint-explicit-runtime-reps and -XLinearTypes) + +This applies to /quantified/ variables like 'w' above. What about +variables that are /free/ in the type being printed, which certainly +happens in error messages. Suppose (#16074, #19361) we are reporting a +mismatch between skolems + (a :: RuntimeRep) ~ (b :: RuntimeRep) + or + (m :: Multiplicity) ~ Many +We certainly don't want to say "Can't match LiftedRep with LiftedRep" or +"Can't match Many with Many"! + +But if we are printing the type + (forall (a :: TYPE r). blah) +we do want to turn that (free) r into LiftedRep, so it prints as + (forall a. blah) + +We use isMetaTyVar to distinguish between those two situations: +metavariables are converted, skolem variables are not. + +There's one exception though: TyVarTv metavariables should not be defaulted, +as they appear during kind-checking of "newtype T :: TYPE r where..." +(test T18357a). Therefore, we additionally test for isTyConableTyVar. +-} + +-- | Default 'RuntimeRep' variables to 'LiftedRep', +-- 'Levity' variables to 'Lifted', and 'Multiplicity' +-- variables to 'Many'. For example: +-- +-- @ +-- ($) :: forall (r :: GHC.Types.RuntimeRep) a (b :: TYPE r). +-- (a -> b) -> a -> b +-- Just :: forall (k :: Multiplicity) a. a % k -> Maybe a +-- @ +-- +-- turns in to, +-- +-- @ ($) :: forall a (b :: *). (a -> b) -> a -> b @ +-- @ Just :: forall a . a -> Maybe a @ +-- +-- We do this to prevent RuntimeRep, Levity and Multiplicity variables from +-- incurring a significant syntactic overhead in otherwise simple +-- type signatures (e.g. ($)). See Note [Defaulting RuntimeRep variables] +-- and #11549 for further discussion. +defaultIfaceTyVarsOfKind :: Bool -- ^ default 'RuntimeRep'/'Levity' variables? + -> Bool -- ^ default 'Multiplicity' variables? + -> IfaceTypePpr -> IfaceTypePpr +defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv ty + where + go :: FastStringEnv IfaceTypePpr -- Set of enclosing forall-ed RuntimeRep/Levity/Multiplicity variables + -> IfaceTypePpr + -> IfaceTypePpr + go subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty) + | isInvisibleArgFlag argf -- Don't default *visible* quantification + -- or we get the mess in #13963 + , Just substituted_ty <- check_substitution var_kind + = let subs' = extendFsEnv subs var substituted_ty + -- Record that we should replace it with LiftedRep/Lifted/Many, + -- and recurse, discarding the forall + in go subs' ty + + go subs (IfaceForAllTy bndr ty) + = IfaceForAllTy (go_ifacebndr subs bndr) (go subs ty) + + go subs ty@(IfaceTyVar tv) = case lookupFsEnv subs tv of + Just s -> s + Nothing -> ty + + go _ ty@(XIfaceType (IfaceFreeTyVar tv)) + -- See Note [Defaulting RuntimeRep variables], about free vars + | def_rep + , GHC.Core.Type.isRuntimeRepTy (tyVarKind tv) + , isMetaTyVar tv + , isTyConableTyVar tv + = liftedRep_ty + | def_rep + , GHC.Core.Type.isLevityTy (tyVarKind tv) + , isMetaTyVar tv + , isTyConableTyVar tv + = lifted_ty + | def_mult + , GHC.Core.Type.isMultiplicityTy (tyVarKind tv) + , isMetaTyVar tv + , isTyConableTyVar tv + = many_ty + | otherwise + = ty + + go subs (IfaceTyConApp tc tc_args) + = IfaceTyConApp tc (go_args subs tc_args) + + go subs (IfaceTupleTy sort is_prom tc_args) + = IfaceTupleTy sort is_prom (go_args subs tc_args) + + go subs (IfaceFunTy af w arg res) + = IfaceFunTy af (go subs w) (go subs arg) (go subs res) + + go subs (IfaceAppTy t ts) + = IfaceAppTy (go subs t) (go_args subs ts) + + go subs (IfaceCastTy x co) + = IfaceCastTy (go subs x) co + + go _ ty@(IfaceLitTy {}) = ty + go _ ty@(IfaceCoercionTy {}) = ty + + go_ifacebndr :: FastStringEnv IfaceTypePpr -> IfaceForAllBndrPpr -> IfaceForAllBndrPpr + go_ifacebndr subs (Bndr (IfaceIdBndr (w, n, t)) argf) + = Bndr (IfaceIdBndr (w, n, go subs t)) argf + go_ifacebndr subs (Bndr (IfaceTvBndr (n, t)) argf) + = Bndr (IfaceTvBndr (n, go subs t)) argf + + go_args :: FastStringEnv IfaceTypePpr -> IfaceAppArgsPpr -> IfaceAppArgsPpr + go_args _ IA_Nil = IA_Nil + go_args subs (IA_Arg ty argf args) + = IA_Arg (go subs ty) argf (go_args subs args) + + check_substitution :: IfaceTypePpr -> Maybe IfaceTypePpr + check_substitution (IfaceTyConApp tc _) + | def_rep + , tc `ifaceTyConHasKey` runtimeRepTyConKey + = Just liftedRep_ty + | def_rep + , tc `ifaceTyConHasKey` levityTyConKey + = Just lifted_ty + | def_mult + , tc `ifaceTyConHasKey` multiplicityTyConKey + = Just many_ty + check_substitution _ = Nothing + +-- | The type ('BoxedRep 'Lifted), also known as LiftedRep. +liftedRep_ty :: IfaceType' p +liftedRep_ty = + IfaceTyConApp liftedRep IA_Nil + where + liftedRep :: IfaceTyCon + liftedRep = IfaceTyCon tc_name (mkIfaceTyConInfo NotPromoted IfaceNormalTyCon) + where tc_name = getName liftedRepTyCon + +-- | The type 'Lifted :: Levity'. +lifted_ty :: IfaceType' p +lifted_ty = + IfaceTyConApp (IfaceTyCon dc_name (mkIfaceTyConInfo IsPromoted IfaceNormalTyCon)) + IA_Nil + where dc_name = getName liftedDataConTyCon + +hideNonStandardTypes :: (IfaceTypePpr -> SDoc) -> IfaceTypePpr -> SDoc +hideNonStandardTypes f ty + = sdocOption sdocPrintExplicitRuntimeReps $ \printExplicitRuntimeReps -> + sdocOption sdocLinearTypes $ \linearTypes -> + getPprStyle $ \sty -> + let def_rep = not printExplicitRuntimeReps + def_mult = not linearTypes + in if userStyle sty + then f (defaultIfaceTyVarsOfKind def_rep def_mult ty) + else f ty + +instance Outputable IfaceAppArgsPpr where + ppr tca = pprIfaceAppArgs tca + +pprIfaceAppArgs, pprParendIfaceAppArgs :: IfaceAppArgsPpr -> SDoc +pprIfaceAppArgs = ppr_app_args topPrec +pprParendIfaceAppArgs = ppr_app_args appPrec + +ppr_app_args :: PprPrec -> IfaceAppArgsPpr -> SDoc +ppr_app_args ctx_prec = go + where + go :: IfaceAppArgsPpr -> SDoc + go IA_Nil = empty + go (IA_Arg t argf ts) = ppr_app_arg ctx_prec (t, argf) <+> go ts + +-- See Note [Pretty-printing invisible arguments] +ppr_app_arg :: PprPrec -> (IfaceTypePpr, ArgFlag) -> SDoc +ppr_app_arg ctx_prec (t, argf) = + sdocOption sdocPrintExplicitKinds $ \print_kinds -> + case argf of + Required -> ppr_ty ctx_prec t + Specified | print_kinds + -> char '@' <> ppr_ty appPrec t + Inferred | print_kinds + -> char '@' <> braces (ppr_ty topPrec t) + _ -> empty + +------------------- +pprIfaceForAllPart :: [IfaceForAllBndrPpr] -> [IfacePredTypePpr] -> SDoc -> SDoc +pprIfaceForAllPart tvs ctxt sdoc + = ppr_iface_forall_part ShowForAllWhen tvs ctxt sdoc + +-- | Like 'pprIfaceForAllPart', but always uses an explicit @forall@. +pprIfaceForAllPartMust :: [IfaceForAllBndrPpr] -> [IfacePredTypePpr] -> SDoc -> SDoc +pprIfaceForAllPartMust tvs ctxt sdoc + = ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc + +pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercionPpr)] -> SDoc -> SDoc +pprIfaceForAllCoPart tvs sdoc + = sep [ pprIfaceForAllCo tvs, sdoc ] + +ppr_iface_forall_part :: ShowForAllFlag + -> [IfaceForAllBndrPpr] -> [IfacePredTypePpr] -> SDoc -> SDoc +ppr_iface_forall_part show_forall tvs ctxt sdoc + = sep [ case show_forall of + ShowForAllMust -> pprIfaceForAll tvs + ShowForAllWhen -> pprUserIfaceForAll tvs + , pprIfaceContextArr ctxt + , sdoc] + +-- | Render the "forall ... ." or "forall ... ->" bit of a type. +pprIfaceForAll :: [IfaceForAllBndrPpr] -> SDoc +pprIfaceForAll [] = empty +pprIfaceForAll bndrs@(Bndr _ vis : _) + = sep [ add_separator (forAllLit <+> fsep docs) + , pprIfaceForAll bndrs' ] + where + (bndrs', docs) = ppr_itv_bndrs bndrs vis + + add_separator stuff = case vis of + Required -> stuff <+> arrow + _inv -> stuff <> dot + + +-- | Render the ... in @(forall ... .)@ or @(forall ... ->)@. +-- Returns both the list of not-yet-rendered binders and the doc. +-- No anonymous binders here! +ppr_itv_bndrs :: [IfaceForAllBndrPpr] + -> ArgFlag -- ^ visibility of the first binder in the list + -> ([IfaceForAllBndrPpr], [SDoc]) +ppr_itv_bndrs all_bndrs@(bndr@(Bndr _ vis) : bndrs) vis1 + | vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in + (bndrs', pprIfaceForAllBndr bndr : doc) + | otherwise = (all_bndrs, []) +ppr_itv_bndrs [] _ = ([], []) + +pprIfaceForAllCo :: [(IfLclName, IfaceCoercionPpr)] -> SDoc +pprIfaceForAllCo [] = empty +pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot + +pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercionPpr)] -> SDoc +pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs + +pprIfaceForAllBndr :: IfaceForAllBndrPpr -> SDoc +pprIfaceForAllBndr bndr = + case bndr of + Bndr (IfaceTvBndr tv) Inferred -> + braces $ pprIfaceTvBndr tv suppress_sig (UseBndrParens False) + Bndr (IfaceTvBndr tv) _ -> + pprIfaceTvBndr tv suppress_sig (UseBndrParens True) + Bndr (IfaceIdBndr idv) _ -> pprIfaceIdBndr idv + where + -- See Note [Suppressing binder signatures] + suppress_sig = SuppressBndrSig False + +pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercionPpr) -> SDoc +pprIfaceForAllCoBndr (tv, kind_co) + = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co) + +-- | Show forall flag +-- +-- Unconditionally show the forall quantifier with ('ShowForAllMust') +-- or when ('ShowForAllWhen') the names used are free in the binder +-- or when compiling with -fprint-explicit-foralls. +data ShowForAllFlag = ShowForAllMust | ShowForAllWhen + +pprIfaceSigmaType :: ShowForAllFlag -> IfaceTypePpr -> SDoc +pprIfaceSigmaType show_forall ty + = hideNonStandardTypes ppr_fn ty + where + ppr_fn iface_ty = + let (invis_tvs, theta, tau) = splitIfaceSigmaTy iface_ty + (req_tvs, tau') = splitIfaceReqForallTy tau + -- splitIfaceSigmaTy is recursive, so it will gather the binders after + -- the theta, i.e. forall a. theta => forall b. tau + -- will give you ([a,b], theta, tau). + -- + -- This isn't right when it comes to visible forall (see + -- testsuite/tests/polykinds/T18522-ppr), + -- so we split off required binders separately, + -- using splitIfaceReqForallTy. + -- + -- An alternative solution would be to make splitIfaceSigmaTy + -- non-recursive (see #18458). + -- Then it could handle both invisible and required binders, and + -- splitIfaceReqForallTy wouldn't be necessary here. + in ppr_iface_forall_part show_forall invis_tvs theta $ + sep [pprIfaceForAll req_tvs, ppr tau'] + +pprUserIfaceForAll :: [IfaceForAllBndrPpr] -> SDoc +pprUserIfaceForAll tvs + = sdocOption sdocPrintExplicitForalls $ \print_foralls -> + -- See Note [When to print foralls] in this module. + ppWhen (any tv_has_kind_var tvs + || any tv_is_required tvs + || print_foralls) $ + pprIfaceForAll tvs + where + tv_has_kind_var (Bndr (IfaceTvBndr (_,kind)) _) + = not (ifTypeIsVarFree kind) + tv_has_kind_var _ = False + + tv_is_required = isVisibleArgFlag . binderArgFlag + +{- +Note [When to print foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We opt to explicitly pretty-print `forall`s if any of the following +criteria are met: + +1. -fprint-explicit-foralls is on. + +2. A bound type variable has a polymorphic kind. E.g., + + forall k (a::k). Proxy a -> Proxy a + + Since a's kind mentions a variable k, we print the foralls. + +3. A bound type variable is a visible argument (#14238). + Suppose we are printing the kind of: + + T :: forall k -> k -> Type + + The "forall k ->" notation means that this kind argument is required. + That is, it must be supplied at uses of T. E.g., + + f :: T (Type->Type) Monad -> Int + + So we print an explicit "T :: forall k -> k -> Type", + because omitting it and printing "T :: k -> Type" would be + utterly misleading. + + See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] + in GHC.Core.TyCo.Rep. + +N.B. Until now (Aug 2018) we didn't check anything for coercion variables. + +Note [Printing foralls in type family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use the same criteria as in Note [When to print foralls] to determine +whether a type family instance should be pretty-printed with an explicit +`forall`. Example: + + type family Foo (a :: k) :: k where + Foo Maybe = [] + Foo (a :: Type) = Int + Foo a = a + +Without -fprint-explicit-foralls enabled, this will be pretty-printed as: + +type family Foo (a :: k) :: k where + Foo Maybe = [] + Foo a = Int + forall k (a :: k). Foo a = a + +Note that only the third equation has an explicit forall, since it has a type +variable with a non-Type kind. (If -fprint-explicit-foralls were enabled, then +the second equation would be preceded with `forall a.`.) + +There is one tricky point in the implementation: what visibility +do we give the type variables in a type family instance? Type family instances +only store type *variables*, not type variable *binders*, and only the latter +has visibility information. We opt to default the visibility of each of these +type variables to Specified because users can't ever instantiate these +variables manually, so the choice of visibility is only relevant to +pretty-printing. (This is why the `k` in `forall k (a :: k). ...` above is +printed the way it is, even though it wasn't written explicitly in the +original source code.) + +We adopt the same strategy for data family instances. Example: + + data family DF (a :: k) + data instance DF '[a, b] = DFList + +That data family instance is pretty-printed as: + + data instance forall j (a :: j) (b :: j). DF '[a, b] = DFList + +This is despite that the representation tycon for this data instance (call it +$DF:List) actually has different visibilities for its binders. +However, the visibilities of these /binders are utterly irrelevant to the +programmer, who cares only about the specificity of variables in `DF`'s type, +not $DF:List's type. Therefore, we opt to pretty-print all variables in data +family instances as Specified. + +Note [Printing promoted type constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this GHCi session (#14343) + > _ :: Proxy '[ 'True ] + error: + Found hole: _ :: Proxy '['True] + +This would be bad, because the '[' looks like a character literal. +Solution: in type-level lists and tuples, add a leading space +if the first type is itself promoted. See pprSpaceIfPromotedTyCon. +-} + + +------------------- + +-- | Prefix a space if the given 'IfaceType' is a promoted 'TyCon'. +-- See Note [Printing promoted type constructors] +pprSpaceIfPromotedTyCon :: IfaceTypePpr -> SDoc -> SDoc +pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _) + = case ifaceTyConIsPromoted (ifaceTyConInfo tyCon) of + IsPromoted -> (space <>) + _ -> id +pprSpaceIfPromotedTyCon _ + = id + +-- See equivalent function in "GHC.Core.TyCo.Rep" +pprIfaceTyList :: PprPrec -> IfaceTypePpr -> IfaceTypePpr -> SDoc +-- Given a type-level list (t1 ': t2), see if we can print +-- it in list notation [t1, ...]. +-- Precondition: Opt_PrintExplicitKinds is off +pprIfaceTyList ctxt_prec ty1 ty2 + = case gather ty2 of + (arg_tys, Nothing) + -> char '\'' <> brackets (pprSpaceIfPromotedTyCon ty1 (fsep + (punctuate comma (map (ppr_ty topPrec) (ty1:arg_tys))))) + (arg_tys, Just tl) + -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1) + 2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]]) + where + gather :: IfaceTypePpr -> ([IfaceTypePpr], Maybe IfaceTypePpr) + -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn] + -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl + gather (IfaceTyConApp tc tys) + | tc `ifaceTyConHasKey` consDataConKey + , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys + , isInvisibleArgFlag argf + , (args, tl) <- gather ty2 + = (ty1:args, tl) + | tc `ifaceTyConHasKey` nilDataConKey + = ([], Nothing) + gather ty = ([], Just ty) + +pprIfaceTypeApp :: PprPrec -> IfaceTyCon -> IfaceAppArgsPpr -> SDoc +pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args + +pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceAppArgsPpr -> SDoc +pprTyTcApp ctxt_prec tc tys = + sdocOption sdocPrintExplicitKinds $ \print_kinds -> + sdocOption sdocPrintTypeAbbreviations $ \print_type_abbreviations -> + getPprDebug $ \debug -> + + 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 + -- NB: pprTuple requires a saturated tuple. + + | IfaceSumTyCon arity <- ifaceTyConSort info + , not debug + , arity == ifaceVisAppArgsLength tys + -> pprSum (ifaceTyConIsPromoted info) tys + -- NB: pprSum requires a saturated unboxed sum. + + | 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 + + | isIfaceTyConAppLiftedTypeKind tc tys + , 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_app_arg appPrec) $ + appArgsIfaceTypesArgFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) args) + -- Use appArgsIfaceTypesArgFlags to print invisible arguments + -- correctly (#19310) + + | tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey + , not debug + -- Suppress detail unless you _really_ want to see + -> text "(TypeError ...)" + + | Just doc <- ppr_equality ctxt_prec tc (appArgsIfaceTypes tys) + -> doc + + | otherwise + -> ppr_iface_tc_app ppr_app_arg ctxt_prec tc $ + appArgsIfaceTypesArgFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) tys + where + info = ifaceTyConInfo tc + +ppr_kind_type :: PprPrec -> SDoc +ppr_kind_type ctxt_prec = sdocOption sdocStarIsType $ \case + False -> pprPrefixOcc liftedTypeKindTyConName + True -> maybeParen ctxt_prec starPrec $ + unicodeSyntax (char '★') (char '*') + +-- | Pretty-print a type-level equality. +-- Returns (Just doc) if the argument is a /saturated/ application +-- of eqTyCon (~) +-- eqPrimTyCon (~#) +-- eqReprPrimTyCon (~R#) +-- heqTyCon (~~) +-- +-- See Note [Equality predicates in IfaceType] +-- and Note [The equality types story] in GHC.Builtin.Types.Prim +ppr_equality :: PprPrec -> IfaceTyCon -> [IfaceTypePpr] -> Maybe SDoc +ppr_equality ctxt_prec tc args + | hetero_eq_tc + , [k1, k2, t1, t2] <- args + = Just $ print_equality (k1, k2, t1, t2) + + | hom_eq_tc + , [k, t1, t2] <- args + = Just $ print_equality (k, k, t1, t2) + + | otherwise + = Nothing + where + homogeneous = tc_name `hasKey` eqTyConKey -- (~) + || hetero_tc_used_homogeneously + where + hetero_tc_used_homogeneously + = case ifaceTyConSort $ ifaceTyConInfo tc of + IfaceEqualityTyCon -> True + _other -> False + -- True <=> a heterogeneous equality whose arguments + -- are (in this case) of the same kind + + tc_name = ifaceTyConName tc + pp = ppr_ty + hom_eq_tc = tc_name `hasKey` eqTyConKey -- (~) + hetero_eq_tc = tc_name `hasKey` eqPrimTyConKey -- (~#) + || tc_name `hasKey` eqReprPrimTyConKey -- (~R#) + || tc_name `hasKey` heqTyConKey -- (~~) + nominal_eq_tc = tc_name `hasKey` heqTyConKey -- (~~) + || tc_name `hasKey` eqPrimTyConKey -- (~#) + print_equality args = + sdocOption sdocPrintExplicitKinds $ \print_kinds -> + sdocOption sdocPrintEqualityRelations $ \print_eqs -> + getPprStyle $ \style -> + getPprDebug $ \debug -> + print_equality' args print_kinds + (print_eqs || dumpStyle style || debug) + + print_equality' (ki1, ki2, ty1, ty2) print_kinds print_eqs + | -- If -fprint-equality-relations is on, just print the original TyCon + print_eqs + = ppr_infix_eq (ppr tc) + + | -- Homogeneous use of heterogeneous equality (ty1 ~~ ty2) + -- or unlifted equality (ty1 ~# ty2) + nominal_eq_tc, homogeneous + = ppr_infix_eq (text "~") + + | -- Heterogeneous use of unlifted equality (ty1 ~# ty2) + not homogeneous + = ppr_infix_eq (ppr heqTyCon) + + | -- Homogeneous use of representational unlifted equality (ty1 ~R# ty2) + tc_name `hasKey` eqReprPrimTyConKey, homogeneous + = let ki | print_kinds = [pp appPrec ki1] + | otherwise = [] + in pprIfacePrefixApp ctxt_prec (ppr coercibleTyCon) + (ki ++ [pp appPrec ty1, pp appPrec ty2]) + + -- The other cases work as you'd expect + | otherwise + = ppr_infix_eq (ppr tc) + where + ppr_infix_eq :: SDoc -> SDoc + ppr_infix_eq eq_op = pprIfaceInfixApp ctxt_prec eq_op + (pp_ty_ki ty1 ki1) (pp_ty_ki ty2 ki2) + where + pp_ty_ki ty ki + | print_kinds + = parens (pp topPrec ty <+> dcolon <+> pp opPrec ki) + | otherwise + = pp opPrec ty + + +pprIfaceCoTcApp :: PprPrec -> IfaceTyCon -> [IfaceCoercionPpr] -> SDoc +pprIfaceCoTcApp ctxt_prec tc tys = + ppr_iface_tc_app (\prec (co, _) -> ppr_co prec co) ctxt_prec tc + (map (, Required) tys) + -- We are trying to re-use ppr_iface_tc_app here, which requires its + -- arguments to be accompanied by visibilities. But visibility is + -- irrelevant when printing coercions, so just default everything to + -- Required. + +-- | Pretty-prints an application of a type constructor to some arguments +-- (whose visibilities are known). This is polymorphic (over @a@) since we use +-- this function to pretty-print two different things: +-- +-- 1. Types (from `pprTyTcApp'`) +-- +-- 2. Coercions (from 'pprIfaceCoTcApp') +ppr_iface_tc_app :: (PprPrec -> (a, ArgFlag) -> SDoc) + -> PprPrec -> IfaceTyCon -> [(a, ArgFlag)] -> SDoc +ppr_iface_tc_app pp _ tc [ty] + | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp topPrec ty) + +ppr_iface_tc_app pp ctxt_prec tc tys + | tc `ifaceTyConHasKey` liftedTypeKindTyConKey + = ppr_kind_type ctxt_prec + + | not (isSymOcc (nameOccName (ifaceTyConName tc))) + = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys) + + | [ ty1@(_, Required) + , ty2@(_, Required) ] <- tys + -- Infix, two visible arguments (we know nothing of precedence though). + -- Don't apply this special case if one of the arguments is invisible, + -- lest we print something like (@LiftedRep -> @LiftedRep) (#15941). + = pprIfaceInfixApp ctxt_prec (ppr tc) + (pp opPrec ty1) (pp opPrec ty2) + + | otherwise + = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys) + +-- | Pretty-print an unboxed sum type. The sum should be saturated: +-- as many visible arguments as the arity of the sum. +-- +-- NB: this always strips off the invisible 'RuntimeRep' arguments, +-- even with `-fprint-explicit-runtime-reps` and `-fprint-explicit-kinds`. +pprSum :: PromotionFlag -> IfaceAppArgsPpr -> SDoc +pprSum is_promoted args + = -- drop the RuntimeRep vars. + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + let tys = appArgsIfaceTypes args + args' = drop (length tys `div` 2) tys + in pprPromotionQuoteI is_promoted + <> sumParens (pprWithBars (ppr_ty topPrec) args') + +-- | Pretty-print a tuple type (boxed tuple, constraint tuple, unboxed tuple). +-- The tuple should be saturated: as many visible arguments as the arity of +-- the tuple. +-- +-- NB: this always strips off the invisible 'RuntimeRep' arguments, +-- even with `-fprint-explicit-runtime-reps` and `-fprint-explicit-kinds`. +pprTuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgsPpr -> SDoc +pprTuple ctxt_prec sort promoted args = + case promoted of + IsPromoted + -> let tys = appArgsIfaceTypes args + args' = drop (length tys `div` 2) tys + spaceIfPromoted = case args' of + arg0:_ -> pprSpaceIfPromotedTyCon arg0 + _ -> id + in ppr_tuple_app args' $ + pprPromotionQuoteI IsPromoted <> + tupleParens sort (spaceIfPromoted (pprWithCommas pprIfaceType args')) + + NotPromoted + | ConstraintTuple <- sort + , IA_Nil <- args + -> maybeParen ctxt_prec sigPrec $ + text "() :: Constraint" + + | otherwise + -> -- drop the RuntimeRep vars. + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + let tys = appArgsIfaceTypes args + args' = case sort of + UnboxedTuple -> drop (length tys `div` 2) tys + _ -> tys + in + ppr_tuple_app args' $ + pprPromotionQuoteI promoted <> + tupleParens sort (pprWithCommas pprIfaceType args') + where + ppr_tuple_app :: [IfaceTypePpr] -> SDoc -> SDoc + ppr_tuple_app args_wo_runtime_reps ppr_args_w_parens + -- Special-case unary boxed tuples so that they are pretty-printed as + -- `Solo x`, not `(x)` + | [_] <- args_wo_runtime_reps + , BoxedTuple <- sort + = let unit_tc_info = mkIfaceTyConInfo promoted IfaceNormalTyCon + unit_tc = IfaceTyCon (tupleTyConName sort 1) unit_tc_info in + pprPrecIfaceType ctxt_prec $ IfaceTyConApp unit_tc args + | otherwise + = ppr_args_w_parens + +pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercionPpr -> SDoc +pprIfaceCoercion = ppr_co topPrec +pprParendIfaceCoercion = ppr_co appPrec + +ppr_co :: PprPrec -> IfaceCoercionPpr -> SDoc +ppr_co _ (IfaceReflCo ty) = angleBrackets (ppr ty) <> ppr_role Nominal +ppr_co _ (IfaceGReflCo r ty IfaceMRefl) + = angleBrackets (ppr ty) <> ppr_role r +ppr_co ctxt_prec (IfaceGReflCo r ty (IfaceMCo co)) + = ppr_special_co ctxt_prec + (text "GRefl" <+> ppr r <+> pprParendIfaceType ty) [co] +ppr_co ctxt_prec (IfaceFunCo r cow co1 co2) + = maybeParen ctxt_prec funPrec $ + sep (ppr_co funPrec co1 : ppr_fun_tail cow co2) + where + ppr_fun_tail cow' (IfaceFunCo r cow co1 co2) + = (coercionArrow cow' <> ppr_role r <+> ppr_co funPrec co1) : ppr_fun_tail cow co2 + ppr_fun_tail cow' other_co + = [coercionArrow cow' <> ppr_role r <+> pprIfaceCoercion other_co] + coercionArrow w = mulArrow (ppr_co topPrec w) + +ppr_co _ (IfaceTyConAppCo r tc cos) + = parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r +ppr_co ctxt_prec (IfaceAppCo co1 co2) + = maybeParen ctxt_prec appPrec $ + ppr_co funPrec co1 <+> pprParendIfaceCoercion co2 +ppr_co ctxt_prec co@(IfaceForAllCo {}) + = maybeParen ctxt_prec funPrec $ + pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co) + where + (tvs, inner_co) = split_co co + + split_co (IfaceForAllCo (IfaceTvBndr (name, _)) kind_co co') + = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') + split_co (IfaceForAllCo (IfaceIdBndr (_, name, _)) kind_co co') + = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') + split_co co' = ([], co') + +-- Why these three? See Note [Free tyvars in IfaceType] +ppr_co _ (IfaceCoVarCo covar) = ppr covar +ppr_co _ (XIfaceCoercion (IfaceFreeCoVar covar)) = ppr covar +ppr_co _ (XIfaceCoercion (IfaceHoleCo covar)) = braces (ppr covar) + +ppr_co _ (IfaceUnivCo prov role ty1 ty2) + = text "Univ" <> (parens $ + sep [ ppr role <+> pprIfaceUnivCoProv prov + , dcolon <+> ppr ty1 <> comma <+> ppr ty2 ]) + +ppr_co ctxt_prec (IfaceInstCo co ty) + = maybeParen ctxt_prec appPrec $ + text "Inst" <+> pprParendIfaceCoercion co + <+> pprParendIfaceCoercion ty + +ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos) + = maybeParen ctxt_prec appPrec $ ppr tc <+> parens (interpp'SP cos) + +ppr_co ctxt_prec (IfaceAxiomInstCo n i cos) + = ppr_special_co ctxt_prec (ppr n <> brackets (ppr i)) cos +ppr_co ctxt_prec (IfaceSymCo co) + = ppr_special_co ctxt_prec (text "Sym") [co] +ppr_co ctxt_prec (IfaceTransCo co1 co2) + -- chain nested TransCo + = let ppr_trans (IfaceTransCo c1 c2) = semi <+> ppr_co topPrec c1 : ppr_trans c2 + ppr_trans c = [semi <+> ppr_co opPrec c] + in maybeParen ctxt_prec opPrec $ + vcat (ppr_co topPrec co1 : ppr_trans co2) +ppr_co ctxt_prec (IfaceNthCo d co) + = ppr_special_co ctxt_prec (text "Nth:" <> int d) [co] +ppr_co ctxt_prec (IfaceLRCo lr co) + = ppr_special_co ctxt_prec (ppr lr) [co] +ppr_co ctxt_prec (IfaceSubCo co) + = ppr_special_co ctxt_prec (text "Sub") [co] +ppr_co ctxt_prec (IfaceKindCo co) + = ppr_special_co ctxt_prec (text "Kind") [co] + +ppr_special_co :: PprPrec -> SDoc -> [IfaceCoercionPpr] -> SDoc +ppr_special_co ctxt_prec doc cos + = maybeParen ctxt_prec appPrec + (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))]) + +ppr_role :: Role -> SDoc +ppr_role r = underscore <> pp_role + where pp_role = case r of + Nominal -> char 'N' + Representational -> char 'R' + Phantom -> char 'P' + +------------------ +pprIfaceUnivCoProv :: IfaceUnivCoProvPpr -> SDoc +pprIfaceUnivCoProv (IfacePhantomProv co) + = text "phantom" <+> pprParendIfaceCoercion co +pprIfaceUnivCoProv (IfaceProofIrrelProv co) + = text "irrel" <+> pprParendIfaceCoercion co +pprIfaceUnivCoProv (IfacePluginProv s) + = text "plugin" <+> doubleQuotes (text s) +pprIfaceUnivCoProv (IfaceCorePrepProv _) + = text "CorePrep" + +------------------- + +instance Outputable IfaceCoercionPpr where + ppr = pprIfaceCoercion + +------------------- + +-- Some notes about printing contexts +-- +-- In the event that we are printing a singleton context (e.g. @Eq a@) we can +-- omit parentheses. However, we must take care to set the precedence correctly +-- to opPrec, since something like @a :~: b@ must be parenthesized (see +-- #9658). +-- +-- When printing a larger context we use 'fsep' instead of 'sep' so that +-- the context doesn't get displayed as a giant column. Rather than, +-- instance (Eq a, +-- Eq b, +-- Eq c, +-- Eq d, +-- Eq e, +-- Eq f, +-- Eq g, +-- Eq h, +-- Eq i, +-- Eq j, +-- Eq k, +-- Eq l) => +-- Eq (a, b, c, d, e, f, g, h, i, j, k, l) +-- +-- we want +-- +-- instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, +-- Eq j, Eq k, Eq l) => +-- Eq (a, b, c, d, e, f, g, h, i, j, k, l) + + + +-- | Prints "(C a, D b) =>", including the arrow. +-- Used when we want to print a context in a type, so we +-- use 'funPrec' to decide whether to parenthesise a singleton +-- predicate; e.g. Num a => a -> a +pprIfaceContextArr :: [IfacePredTypePpr] -> SDoc +pprIfaceContextArr [] = empty +pprIfaceContextArr [pred] = ppr_ty funPrec pred <+> darrow +pprIfaceContextArr preds = ppr_parend_preds preds <+> darrow + +-- | Prints a context or @()@ if empty +-- You give it the context precedence +pprIfaceContext :: PprPrec -> [IfacePredTypePpr] -> SDoc +pprIfaceContext _ [] = text "()" +pprIfaceContext prec [pred] = ppr_ty prec pred +pprIfaceContext _ preds = ppr_parend_preds preds + +ppr_parend_preds :: [IfacePredTypePpr] -> SDoc +ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds))) diff --git a/compiler/GHC/Iface/Type/Ppr.hs-boot b/compiler/GHC/Iface/Type/Ppr.hs-boot new file mode 100644 index 0000000000..67494283e7 --- /dev/null +++ b/compiler/GHC/Iface/Type/Ppr.hs-boot @@ -0,0 +1,21 @@ +module GHC.Iface.Type.Ppr + ( IfaceTypePpr, IfaceBndrPpr + , IfaceCoercionPpr, IfaceAppArgsPpr + ) +where + +-- Empty import to influence the compilation ordering. +-- See Note [Depend on GHC.Num.Integer] in GHC.Base +import GHC.Base () + +data IfaceType' p +data IfaceAppArgs' p +data IfaceBndr' p +data IfaceCoercion' p + +data TtgIfacePpr + +type IfaceTypePpr = IfaceType' TtgIfacePpr +type IfaceAppArgsPpr = IfaceAppArgs' TtgIfacePpr +type IfaceBndrPpr = IfaceBndr' TtgIfacePpr +type IfaceCoercionPpr = IfaceCoercion' TtgIfacePpr diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs index 6a33787d87..d244dcd8f7 100644 --- a/compiler/Language/Haskell/Syntax/Extension.hs +++ b/compiler/Language/Haskell/Syntax/Extension.hs @@ -28,6 +28,8 @@ import Data.Data hiding ( Fixity ) import Data.Kind (Type) import GHC.Utils.Outputable +import Control.DeepSeq + {- Note [Trees That Grow] ~~~~~~~~~~~~~~~~~~~~~~ @@ -114,6 +116,9 @@ data DataConCantHappen instance Outputable DataConCantHappen where ppr = dataConCantHappen +instance NFData DataConCantHappen where + rnf = dataConCantHappen + -- | Eliminate a 'DataConCantHappen'. See Note [Constructor cannot occur]. dataConCantHappen :: DataConCantHappen -> a dataConCantHappen x = case x of {} |