diff options
48 files changed, 1200 insertions, 1132 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index 4f574356cf..ce00c45351 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -19,6 +19,9 @@ types that module BasicTypes( Version, bumpVersion, initialVersion, + LeftOrRight(..), + pickLR, + ConTag, ConTagZ, fIRST_TAG, Arity, RepArity, @@ -48,6 +51,8 @@ module BasicTypes( Boxity(..), isBoxed, + TyPrec(..), maybeParen, + TupleSort(..), tupleSortBoxity, boxityTupleSort, tupleParens, @@ -105,6 +110,25 @@ import Data.Function (on) {- ************************************************************************ * * + Binary choice +* * +************************************************************************ +-} + +data LeftOrRight = CLeft | CRight + deriving( Eq, Data ) + +pickLR :: LeftOrRight -> (a,a) -> a +pickLR CLeft (l,_) = l +pickLR CRight (_,r) = r + +instance Outputable LeftOrRight where + ppr CLeft = text "Left" + ppr CRight = text "Right" + +{- +************************************************************************ +* * \subsection[Arity]{Arity} * * ************************************************************************ @@ -627,6 +651,26 @@ pprSafeOverlap False = empty {- ************************************************************************ * * + Type precedence +* * +************************************************************************ +-} + +data TyPrec -- See Note [Prededence in types] + = TopPrec -- No parens + | FunPrec -- Function args; no parens for tycon apps + | TyOpPrec -- Infix operator + | TyConPrec -- Tycon args; no parens for atomic + deriving( Eq, Ord ) + +maybeParen :: TyPrec -> TyPrec -> SDoc -> SDoc +maybeParen ctxt_prec inner_prec pretty + | ctxt_prec < inner_prec = pretty + | otherwise = parens pretty + +{- +************************************************************************ +* * Tuples * * ************************************************************************ diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 74f8a618a7..314bf3e80a 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -1003,7 +1003,7 @@ lintCoBndr cv thing_inside ; let (subst', cv') = substCoVarBndr subst cv ; lintKind (varType cv') ; lintL (isCoercionType (varType cv')) - (text "CoVar with non-coercion type:" <+> pprTvBndr cv) + (text "CoVar with non-coercion type:" <+> pprTyVar cv) ; updateTCvSubst subst' (thing_inside cv') } lintIdBndr :: Id -> (Id -> LintM a) -> LintM a diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs index ce8a68b032..9129c9012f 100644 --- a/compiler/coreSyn/PprCore.hs +++ b/compiler/coreSyn/PprCore.hs @@ -378,7 +378,7 @@ pprTypedLetBinder binder pprKindedTyVarBndr :: TyVar -> SDoc -- Print a type variable binder with its kind (but not if *) pprKindedTyVarBndr tyvar - = text "@" <+> pprTvBndr tyvar + = text "@" <+> pprTyVar tyvar -- pprIdBndr does *not* print the type -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index ba7f6194fe..0a85ff1a5d 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -314,6 +314,7 @@ Library IfaceEnv IfaceSyn IfaceType + ToIface LoadIface MkIface TcIface diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 91a0277e03..2b85e42b68 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -493,6 +493,7 @@ compiler_stage2_dll0_MODULES = \ IdInfo \ IfaceSyn \ IfaceType \ + ToIface \ InstEnv \ Kind \ KnownUniques \ diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 795e5b1675..4a5672a7c1 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -62,6 +62,7 @@ import Fingerprint import Binary import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) import Var( TyVarBndr(..) ) +import Type ( TyPrec(..) ) import TyCon ( Role (..), Injectivity(..), HowAbstract(..) ) import StaticFlags (opt_PprStyle_Debug) import Util( filterOut, filterByList ) @@ -540,9 +541,10 @@ pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs where ppr_binders | null tvs && null cvs = empty - | null cvs = brackets (pprWithCommas pprIfaceTvBndr tvs) + | null cvs + = brackets (pprWithCommas (pprIfaceTvBndr True) tvs) | otherwise - = brackets (pprWithCommas pprIfaceTvBndr tvs <> semi <+> + = brackets (pprWithCommas (pprIfaceTvBndr True) tvs <> semi <+> pprWithCommas pprIfaceIdBndr cvs) pp_lhs = hang pp_tc 2 (pprParendIfaceTcArgs pat_tys) maybe_incomps = ppUnless (null incomps) $ parens $ @@ -876,7 +878,7 @@ pprIfaceTyConParent IfNoParent pprIfaceTyConParent (IfDataInstance _ tc tys) = sdocWithDynFlags $ \dflags -> let ftys = stripInvisArgs dflags tys - in pprIfaceTypeApp tc ftys + in pprIfaceTypeApp TopPrec tc ftys pprIfaceDeclHead :: IfaceContext -> ShowSub -> Name -> [IfaceTyConBinder] -- of the tycon, for invisible-suppression @@ -1336,6 +1338,7 @@ freeNamesIfProv IfaceUnsafeCoerceProv = emptyNameSet freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co freeNamesIfProv (IfacePluginProv _) = emptyNameSet +freeNamesIfProv (IfaceHoleProv _) = emptyNameSet freeNamesIfTyVarBndr :: TyVarBndr IfaceTvBndr vis -> NameSet freeNamesIfTyVarBndr (TvBndr tv _) = freeNamesIfTvBndr tv diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index f200872ed0..d6a9a212e1 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -6,7 +6,7 @@ This module defines interface types and binders -} -{-# LANGUAGE CPP, FlexibleInstances #-} +{-# LANGUAGE CPP, FlexibleInstances, BangPatterns #-} -- FlexibleInstances for Binary (DefMethSpec IfaceType) module IfaceType ( @@ -14,39 +14,31 @@ module IfaceType ( IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..), IfaceUnivCoProv(..), - IfaceTyCon(..), IfaceTyConInfo(..), + IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), IsPromoted(..), IfaceTyLit(..), IfaceTcArgs(..), IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder, IfaceForAllBndr, ArgFlag(..), - ifConstraintKind, ifTyConBinderTyVar, ifTyConBinderName, + ifTyConBinderTyVar, ifTyConBinderName, -- Equality testing IfRnEnv2, emptyIfRnEnv2, eqIfaceType, eqIfaceTypes, eqIfaceTcArgs, eqIfaceTvBndrs, isIfaceLiftedTypeKind, - -- Conversion from Type -> IfaceType - toIfaceType, toIfaceTypes, toIfaceKind, toIfaceTyVar, - toIfaceContext, toIfaceBndr, toIfaceIdBndr, - toIfaceTyCon, toIfaceTyCon_name, - toIfaceTcArgs, toIfaceTvBndr, toIfaceTvBndrs, - toIfaceForAllBndr, - - -- Conversion from IfaceTcArgs -> IfaceType + -- Conversion from IfaceTcArgs -> [IfaceType] tcArgsIfaceTypes, - -- Conversion from Coercion -> IfaceCoercion - toIfaceCoercion, - -- Printing pprIfaceType, pprParendIfaceType, pprIfaceContext, pprIfaceContextArr, pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders, pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs, pprIfaceForAllPart, pprIfaceForAll, pprIfaceSigmaType, + pprIfaceTyLit, pprIfaceCoercion, pprParendIfaceCoercion, splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll, + pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp, suppressIfaceInvisibles, stripIfaceInvisVars, @@ -57,29 +49,26 @@ module IfaceType ( #include "HsVersions.h" -import Coercion -import DataCon ( isTupleDataCon ) -import TcType +import {-# SOURCE #-} TysWiredIn ( ptrRepLiftedDataConTyCon ) + import DynFlags -import TyCoRep -- needs to convert core types to iface types +import StaticFlags ( opt_PprStyle_Debug ) import TyCon hiding ( pprPromotionQuote ) import CoAxiom -import Id import Var --- import RnEnv( FastStringEnv, mkFsEnv, lookupFsEnv ) -import TysWiredIn -import TysPrim import PrelNames import Name import BasicTypes import Binary import Outputable import FastString +import FastStringEnv import UniqSet -import VarEnv import UniqFM import Util +import Data.List (foldl') + {- ************************************************************************ * * @@ -132,8 +121,10 @@ data IfaceType -- A kind of universal type, used for types and kinds -- Includes newtypes, synonyms, tuples | IfaceCastTy IfaceType IfaceCoercion | IfaceCoercionTy IfaceCoercion + | IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp) - TupleSort IfaceTyConInfo -- A bit like IfaceTyCon + TupleSort -- What sort of tuple? + IsPromoted -- A bit like IfaceTyCon IfaceTcArgs -- arity = length args -- For promoted data cons, the kind args are omitted @@ -159,6 +150,12 @@ data IfaceTcArgs | ITC_Invis IfaceKind IfaceTcArgs -- "Invis" means don't show when pretty-printing -- except with -fprint-explicit-kinds +instance Monoid IfaceTcArgs where + mempty = ITC_Nil + ITC_Nil `mappend` xs = xs + ITC_Vis ty rest `mappend` xs = ITC_Vis ty (rest `mappend` xs) + ITC_Invis ki rest `mappend` xs = ITC_Invis ki (rest `mappend` xs) + -- Encodes type constructors, kind constructors, -- coercion constructors, the lot. -- We have to tag them in order to pretty print them @@ -167,10 +164,58 @@ data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName , ifaceTyConInfo :: IfaceTyConInfo } deriving (Eq) +-- | Is a TyCon a promoted data constructor or just a normal type constructor? +data IsPromoted = IsNotPromoted | IsPromoted + deriving (Eq) + +-- | The various types of TyCons which have special, built-in syntax. +data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon + + | IfaceTupleTyCon !Arity !TupleSort + -- ^ e.g. @(a, b, c)@ or @(#a, b, c#)@. + -- The arity is the tuple width, not the tycon arity + -- (which is twice the width in the case of unboxed + -- tuples). + + | IfaceSumTyCon !Arity + -- ^ e.g. @(a | b | c)@ + + | IfaceEqualityTyCon !Bool + -- ^ a type equality. 'True' indicates kind-homogeneous. + -- See Note [Equality predicates in IfaceType] for + -- details. + deriving (Eq) + +{- +Note [Equality predicates in IfaceType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC has several varieties of type equality (see Note [The equality types story] +in TysPrim for details) which all must be rendered with different surface syntax +during pretty-printing. Which syntax we use depends upon, + + 1. Which predicate tycon was used + 2. Whether the types being compared are of the same kind. + +Unfortunately, determining (2) from an IfaceType isn't possible since we can't +see through type synonyms. Consequently, we need to record whether the equality +is homogeneous or not in IfaceTyConSort for the purposes of pretty-printing. + +Namely we handle these cases, + + Predicate Homogeneous Heterogeneous + ---------------- ----------- ------------- + eqTyCon ~ N/A + heqTyCon ~ ~~ + eqPrimTyCon ~# ~~ + eqReprPrimTyCon Coercible Coercible + +-} + data IfaceTyConInfo -- Used to guide pretty-printing -- and to disambiguate D from 'D (they share a name) - = NoIfaceTyConInfo - | IfacePromotedDataCon + = IfaceTyConInfo { ifaceTyConIsPromoted :: IsPromoted + , ifaceTyConSort :: IfaceTyConSort } deriving (Eq) data IfaceCoercion @@ -197,12 +242,21 @@ data IfaceUnivCoProv | IfacePhantomProv IfaceCoercion | IfaceProofIrrelProv IfaceCoercion | IfacePluginProv String + | IfaceHoleProv Unique + -- ^ See Note [Holes in IfaceUnivCoProv] --- this constant is needed for dealing with pretty-printing classes -ifConstraintKind :: IfaceKind -ifConstraintKind = IfaceTyConApp (IfaceTyCon { ifaceTyConName = getName constraintKindTyCon - , ifaceTyConInfo = NoIfaceTyConInfo }) - ITC_Nil +{- +Note [Holes in IfaceUnivCoProv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking fails the typechecker will produce a HoleProv UnivCoProv to +stand in place of the unproven assertion. While we generally don't want to let +these unproven assertions leak into interface files, we still need to be able to +pretty-print them as we use IfaceType's pretty-printer to render Types. For this +reason IfaceUnivCoProv has a IfaceHoleProv constructor; however, we fails when +asked to serialize to a IfaceHoleProv to ensure that they don't end up in an +interface file. To avoid an import loop between IfaceType and TyCoRep we only +keep the hole's Unique, since that is all we need to print. +-} {- %************************************************************************ @@ -212,6 +266,9 @@ ifConstraintKind = IfaceTyConApp (IfaceTyCon { ifaceTyConName = getName constrai ************************************************************************ -} +ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool +ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key + eqIfaceTvBndr :: IfaceTvBndr -> IfaceTvBndr -> Bool eqIfaceTvBndr (occ1, _) (occ2, _) = occ1 == occ2 @@ -220,8 +277,8 @@ isIfaceLiftedTypeKind (IfaceTyConApp tc ITC_Nil) = isLiftedTypeKindTyConName (ifaceTyConName tc) isIfaceLiftedTypeKind (IfaceTyConApp tc (ITC_Vis (IfaceTyConApp ptr_rep_lifted ITC_Nil) ITC_Nil)) - = ifaceTyConName tc == tYPETyConName - && ifaceTyConName ptr_rep_lifted `hasKey` ptrRepLiftedDataConKey + = tc `ifaceTyConHasKey` tYPETyConKey + && ptr_rep_lifted `ifaceTyConHasKey` ptrRepLiftedDataConKey isIfaceLiftedTypeKind _ = False splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType) @@ -327,6 +384,7 @@ ifTyVarsOfCoercion = go go_prov (IfacePhantomProv co) = go co go_prov (IfaceProofIrrelProv co) = go co go_prov (IfacePluginProv _) = emptyUniqSet + go_prov (IfaceHoleProv _) = emptyUniqSet ifTyVarsOfCoercions :: [IfaceCoercion] -> UniqSet IfLclName ifTyVarsOfCoercions = foldr (unionUniqSets . ifTyVarsOfCoercion) emptyUniqSet @@ -381,6 +439,7 @@ substIfaceType env ty go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co) go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co) go_prov (IfacePluginProv str) = IfacePluginProv str + go_prov (IfaceHoleProv h) = IfaceHoleProv h substIfaceTcArgs :: IfaceTySubst -> IfaceTcArgs -> IfaceTcArgs substIfaceTcArgs env args @@ -512,37 +571,18 @@ stripInvisArgs dflags tys ITC_Invis _ ts -> suppress_invis ts _ -> c -toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs --- See Note [Suppressing invisible arguments] -toIfaceTcArgs tc ty_args - = go (mkEmptyTCvSubst in_scope) (tyConKind tc) ty_args - where - in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) - - go _ _ [] = ITC_Nil - go env ty ts - | Just ty' <- coreView ty - = go env ty' ts - go env (ForAllTy (TvBndr tv vis) res) (t:ts) - | isVisibleArgFlag vis = ITC_Vis t' ts' - | otherwise = ITC_Invis t' ts' - where - t' = toIfaceType t - ts' = go (extendTvSubst env tv t) res ts - - go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps - = ITC_Vis (toIfaceType t) (go env res ts) - - go env (TyVarTy tv) ts - | Just ki <- lookupTyVar env tv = go env ki ts - go env kind (t:ts) = WARN( True, ppr tc $$ ppr (tyConKind tc) $$ ppr ty_args ) - ITC_Vis (toIfaceType t) (go env kind ts) -- Ill-kinded - tcArgsIfaceTypes :: IfaceTcArgs -> [IfaceType] tcArgsIfaceTypes ITC_Nil = [] tcArgsIfaceTypes (ITC_Invis t ts) = t : tcArgsIfaceTypes ts tcArgsIfaceTypes (ITC_Vis t ts) = t : tcArgsIfaceTypes ts +ifaceVisTcArgsLength :: IfaceTcArgs -> Int +ifaceVisTcArgsLength = go 0 + where + go !n ITC_Nil = n + go n (ITC_Vis _ rest) = go (n+1) rest + go n (ITC_Invis _ rest) = go n rest + {- Note [Suppressing invisible arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -565,6 +605,17 @@ we want ************************************************************************ -} +if_print_coercions :: SDoc -- ^ if printing coercions + -> SDoc -- ^ otherwise + -> SDoc +if_print_coercions yes no + = sdocWithDynFlags $ \dflags -> + getPprStyle $ \style -> + if gopt Opt_PrintExplicitCoercions dflags + || dumpStyle style || debugStyle style + then yes + else no + pprIfaceInfixApp :: (TyPrec -> a -> SDoc) -> TyPrec -> SDoc -> a -> a -> SDoc pprIfaceInfixApp pp p pp_tc ty1 ty2 = maybeParen p FunPrec $ @@ -580,7 +631,7 @@ pprIfacePrefixApp p pp_fun pp_tys instance Outputable IfaceBndr where ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr - ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr bndr + ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr False bndr pprIfaceBndrs :: [IfaceBndr] -> SDoc pprIfaceBndrs bs = sep (map ppr bs) @@ -589,18 +640,21 @@ pprIfaceLamBndr :: IfaceLamBndr -> SDoc pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]" -pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc +pprIfaceIdBndr :: IfaceIdBndr -> SDoc pprIfaceIdBndr (name, ty) = parens (ppr name <+> dcolon <+> ppr ty) -pprIfaceTvBndr :: IfaceTvBndr -> SDoc -pprIfaceTvBndr (tv, ki) +pprIfaceTvBndr :: Bool -> IfaceTvBndr -> SDoc +pprIfaceTvBndr use_parens (tv, ki) | isIfaceLiftedTypeKind ki = ppr tv - | otherwise = parens (ppr tv <+> dcolon <+> ppr ki) + | otherwise = maybe_parens (ppr tv <+> dcolon <+> ppr ki) + where + maybe_parens | use_parens = parens + | otherwise = id pprIfaceTyConBinders :: [IfaceTyConBinder] -> SDoc pprIfaceTyConBinders = sep . map go where - go tcb = pprIfaceTvBndr (ifTyConBinderTyVar tcb) + go tcb = pprIfaceTvBndr True (ifTyConBinderTyVar tcb) instance Binary IfaceBndr where put_ bh (IfaceIdBndr aa) = do @@ -634,15 +688,15 @@ instance Binary IfaceOneShot where instance Outputable IfaceType where ppr ty = pprIfaceType ty -pprIfaceType, pprParendIfaceType ::IfaceType -> SDoc -pprIfaceType = ppr_ty TopPrec -pprParendIfaceType = ppr_ty TyConPrec +pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc +pprIfaceType = eliminateRuntimeRep (ppr_ty TopPrec) +pprParendIfaceType = eliminateRuntimeRep (ppr_ty TyConPrec) ppr_ty :: TyPrec -> IfaceType -> SDoc ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -ppr_ty ctxt_prec (IfaceTyConApp tc tys) = sdocWithDynFlags (pprTyTcApp ctxt_prec tc tys) -ppr_ty _ (IfaceTupleTy s i tys) = pprTuple s i tys -ppr_ty _ (IfaceLitTy n) = ppr_tylit n +ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys +ppr_ty _ (IfaceTupleTy i p tys) = pprTuple i p tys +ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n -- Function types ppr_ty ctxt_prec (IfaceFunTy ty1 ty2) = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. @@ -655,19 +709,133 @@ ppr_ty ctxt_prec (IfaceFunTy ty1 ty2) = [arrow <+> pprIfaceType other_ty] ppr_ty ctxt_prec (IfaceAppTy ty1 ty2) - = maybeParen ctxt_prec TyConPrec $ - ppr_ty FunPrec ty1 <+> pprParendIfaceType ty2 + = if_print_coercions + ppr_app_ty + ppr_app_ty_no_casts + where + ppr_app_ty = + maybeParen ctxt_prec TyConPrec + $ ppr_ty FunPrec ty1 <+> ppr_ty TyConPrec ty2 + + -- Strip any casts from the head of the application + ppr_app_ty_no_casts = + case split_app_tys ty1 (ITC_Vis ty2 ITC_Nil) of + (IfaceCastTy head _, args) -> ppr_ty ctxt_prec (mk_app_tys head args) + _ -> ppr_app_ty + + split_app_tys :: IfaceType -> IfaceTcArgs -> (IfaceType, IfaceTcArgs) + split_app_tys (IfaceAppTy t1 t2) args = split_app_tys t1 (t2 `ITC_Vis` args) + split_app_tys head args = (head, args) + + mk_app_tys :: IfaceType -> IfaceTcArgs -> IfaceType + mk_app_tys (IfaceTyConApp tc tys1) tys2 = + IfaceTyConApp tc (tys1 `mappend` tys2) + mk_app_tys t1 tys2 = + foldl' IfaceAppTy t1 (tcArgsIfaceTypes tys2) ppr_ty ctxt_prec (IfaceCastTy ty co) - = maybeParen ctxt_prec FunPrec $ - sep [ppr_ty FunPrec ty, text "`cast`", ppr_co FunPrec co] + = if_print_coercions + (parens (ppr_ty TopPrec ty <+> text "|>" <+> ppr co)) + (ppr_ty ctxt_prec ty) ppr_ty ctxt_prec (IfaceCoercionTy co) - = ppr_co ctxt_prec co + = if_print_coercions + (ppr_co ctxt_prec co) + (text "<>") ppr_ty ctxt_prec ty = maybeParen ctxt_prec FunPrec (ppr_iface_sigma_type True ty) +{- +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 signficant 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 +PtrLiftedRep. This is done in a pass right before pretty-printing +(defaultRuntimeRepVars, controlled by -fprint-explicit-runtime-reps) +-} + +-- | Default 'RuntimeRep' variables to 'LiftedPtr'. e.g. +-- +-- @ +-- ($) :: forall (r :: GHC.Types.RuntimeRep) a (b :: TYPE r). +-- (a -> b) -> a -> b +-- @ +-- +-- turns in to, +-- +-- @ ($) :: forall a (b :: *). (a -> b) -> a -> b @ +-- +-- We do this to prevent RuntimeRep variables from incurring a significant +-- syntactic overhead in otherwise simple type signatures (e.g. ($)). See +-- Note [Defaulting RuntimeRep variables] and #11549 for further discussion. +-- +defaultRuntimeRepVars :: IfaceType -> IfaceType +defaultRuntimeRepVars = go emptyFsEnv + where + go :: FastStringEnv () -> IfaceType -> IfaceType + go subs (IfaceForAllTy bndr ty) + | isRuntimeRep var_kind + = let subs' = extendFsEnv subs var () + in go subs' ty + | otherwise + = IfaceForAllTy (TvBndr (var, go subs var_kind) (binderArgFlag bndr)) + (go subs ty) + where + var :: IfLclName + (var, var_kind) = binderVar bndr + + go subs (IfaceTyVar tv) + | tv `elemFsEnv` subs + = IfaceTyConApp ptrRepLifted ITC_Nil + + go subs (IfaceFunTy kind ty) + = IfaceFunTy (go subs kind) (go subs ty) + + go subs (IfaceAppTy x y) + = IfaceAppTy (go subs x) (go subs y) + + go subs (IfaceDFunTy x y) + = IfaceDFunTy (go subs x) (go subs y) + + go subs (IfaceCastTy x co) + = IfaceCastTy (go subs x) co + + go _ other = other + + ptrRepLifted :: IfaceTyCon + ptrRepLifted = + IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon) + where dc_name = getName ptrRepLiftedDataConTyCon + + isRuntimeRep :: IfaceType -> Bool + isRuntimeRep (IfaceTyConApp tc _) = + tc `ifaceTyConHasKey` runtimeRepTyConKey + isRuntimeRep _ = False + +eliminateRuntimeRep :: (IfaceType -> SDoc) -> IfaceType -> SDoc +eliminateRuntimeRep f ty = sdocWithDynFlags $ \dflags -> + if gopt Opt_PrintExplicitRuntimeReps dflags + then f ty + else f (defaultRuntimeRepVars ty) + instance Outputable IfaceTcArgs where ppr tca = pprIfaceTcArgs tca @@ -691,15 +859,15 @@ ppr_iface_sigma_type show_foralls_unconditionally ty (tvs, theta, tau) = splitIfaceSigmaTy ty ------------------- -pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfaceType] -> SDoc -> SDoc +pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc pprIfaceForAllPart tvs ctxt sdoc = ppr_iface_forall_part False tvs ctxt sdoc pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc -pprIfaceForAllCoPart tvs sdoc = sep [ pprIfaceForAllCo tvs - , sdoc ] +pprIfaceForAllCoPart tvs sdoc = + sep [ pprIfaceForAllCo tvs, sdoc ] -ppr_iface_forall_part :: Outputable a - => Bool -> [IfaceForAllBndr] -> [a] -> SDoc -> SDoc +ppr_iface_forall_part :: Bool + -> [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc ppr_iface_forall_part show_foralls_unconditionally tvs ctxt sdoc = sep [ if show_foralls_unconditionally then pprIfaceForAll tvs @@ -711,7 +879,7 @@ ppr_iface_forall_part show_foralls_unconditionally tvs ctxt sdoc pprIfaceForAll :: [IfaceForAllBndr] -> SDoc pprIfaceForAll [] = empty pprIfaceForAll bndrs@(TvBndr _ vis : _) - = add_separator (text "forall" <+> doc) <+> pprIfaceForAll bndrs' + = add_separator (forAllLit <+> doc) <+> pprIfaceForAll bndrs' where (bndrs', doc) = ppr_itv_bndrs bndrs vis @@ -742,9 +910,9 @@ pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc pprIfaceForAllBndr (TvBndr tv Inferred) = sdocWithDynFlags $ \dflags -> if gopt Opt_PrintExplicitForalls dflags - then braces $ pprIfaceTvBndr tv - else pprIfaceTvBndr tv -pprIfaceForAllBndr (TvBndr tv _) = pprIfaceTvBndr tv + then braces $ pprIfaceTvBndr False tv + else pprIfaceTvBndr True tv +pprIfaceForAllBndr (TvBndr tv _) = pprIfaceTvBndr True tv pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc pprIfaceForAllCoBndr (tv, kind_co) @@ -782,53 +950,129 @@ pprIfaceTyList ctxt_prec ty1 ty2 -- (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) - | tcname == consDataConName + | tc `ifaceTyConHasKey` consDataConKey , (ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil))) <- tys , (args, tl) <- gather ty2 = (ty1:args, tl) - | tcname == nilDataConName + | tc `ifaceTyConHasKey` nilDataConKey = ([], Nothing) - where tcname = ifaceTyConName tc gather ty = ([], Just ty) -pprIfaceTypeApp :: IfaceTyCon -> IfaceTcArgs -> SDoc -pprIfaceTypeApp tc args = sdocWithDynFlags (pprTyTcApp TopPrec tc args) +pprIfaceTypeApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc +pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args + +pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc +pprTyTcApp ctxt_prec tc tys = + sdocWithDynFlags $ \dflags -> + getPprStyle $ \style -> + pprTyTcApp' ctxt_prec tc tys dflags style -pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> DynFlags -> SDoc -pprTyTcApp ctxt_prec tc tys dflags +pprTyTcApp' :: TyPrec -> IfaceTyCon -> IfaceTcArgs + -> DynFlags -> PprStyle -> SDoc +pprTyTcApp' ctxt_prec tc tys dflags style | ifaceTyConName tc `hasKey` ipClassKey , ITC_Vis (IfaceLitTy (IfaceStrTyLit n)) (ITC_Vis ty ITC_Nil) <- tys - = char '?' <> ftext n <> text "::" <> ppr_ty TopPrec ty + = maybeParen ctxt_prec FunPrec + $ char '?' <> ftext n <> text "::" <> ppr_ty TopPrec ty - | ifaceTyConName tc == consDataConName + | IfaceTupleTyCon arity sort <- ifaceTyConSort info + , not (debugStyle style) + , arity == ifaceVisTcArgsLength tys + = pprTuple sort (ifaceTyConIsPromoted info) tys + + | IfaceSumTyCon arity <- ifaceTyConSort info + = pprSum arity (ifaceTyConIsPromoted info) tys + + | tc `ifaceTyConHasKey` consDataConKey , not (gopt Opt_PrintExplicitKinds dflags) , ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil)) <- tys = pprIfaceTyList ctxt_prec ty1 ty2 - | ifaceTyConName tc == tYPETyConName - , ITC_Vis (IfaceTyConApp ptr_rep ITC_Nil) ITC_Nil <- tys - , ifaceTyConName ptr_rep `hasKey` ptrRepLiftedDataConKey - = char '*' + | tc `ifaceTyConHasKey` tYPETyConKey + , ITC_Vis (IfaceTyConApp rep ITC_Nil) ITC_Nil <- tys + , rep `ifaceTyConHasKey` ptrRepLiftedDataConKey + = unicodeSyntax (char '★') (char '*') - | ifaceTyConName tc == tYPETyConName - , ITC_Vis (IfaceTyConApp ptr_rep ITC_Nil) ITC_Nil <- tys - , ifaceTyConName ptr_rep `hasKey` ptrRepUnliftedDataConKey + | tc `ifaceTyConHasKey` tYPETyConKey + , ITC_Vis (IfaceTyConApp rep ITC_Nil) ITC_Nil <- tys + , rep `ifaceTyConHasKey` ptrRepUnliftedDataConKey = char '#' + | not opt_PprStyle_Debug + , tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey + = text "(TypeError ...)" -- Suppress detail unles you _really_ want to see + + | Just doc <- ppr_equality tc (tcArgsIfaceTypes tys) + = doc + | otherwise = ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds where + info = ifaceTyConInfo tc tys_wo_kinds = tcArgsIfaceTypes $ stripInvisArgs dflags tys +-- | Pretty-print a type-level equality. +-- +-- See Note [Equality predicates in IfaceType]. +ppr_equality :: IfaceTyCon -> [IfaceType] -> Maybe SDoc +ppr_equality 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 = case ifaceTyConSort $ ifaceTyConInfo tc of + IfaceEqualityTyCon hom -> hom + _other -> pprPanic "ppr_equality: homogeneity" (ppr tc) + 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 -- (~~) + + print_equality args = + sdocWithDynFlags + $ \dflags -> getPprStyle + $ \style -> print_equality' args style dflags + + print_equality' (ki1, ki2, ty1, ty2) style dflags + | print_eqs + = ppr_infix_eq (ppr tc) + + | hetero_eq_tc + , print_kinds || not homogeneous + = ppr_infix_eq (text "~~") + + | otherwise + = if tc_name `hasKey` eqReprPrimTyConKey + then text "Coercible" + <+> sep [ pp TyConPrec ty1, pp TyConPrec ty2 ] + else sep [pp TyOpPrec ty1, char '~', pp TyOpPrec ty2] + where + ppr_infix_eq eq_op + = sep [ parens (pp TyOpPrec ty1 <+> dcolon <+> pp TyOpPrec ki1) + , eq_op + , parens (pp TyOpPrec ty2 <+> dcolon <+> pp TyOpPrec ki2) ] + + print_kinds = gopt Opt_PrintExplicitKinds dflags + print_eqs = gopt Opt_PrintEqualityRelations dflags || + dumpStyle style || debugStyle style + + pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys ppr_iface_tc_app :: (TyPrec -> a -> SDoc) -> TyPrec -> IfaceTyCon -> [a] -> SDoc ppr_iface_tc_app pp _ tc [ty] - | n == listTyConName = pprPromotionQuote tc <> brackets (pp TopPrec ty) - | n == parrTyConName = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) - where - n = ifaceTyConName tc + | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty) + | tc `ifaceTyConHasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) ppr_iface_tc_app pp ctxt_prec tc tys | not (isSymOcc (nameOccName tc_name)) @@ -838,8 +1082,9 @@ ppr_iface_tc_app pp ctxt_prec tc tys -- we know nothing of precedence though = pprIfaceInfixApp pp ctxt_prec (ppr tc) ty1 ty2 - | tc_name == starKindTyConName || tc_name == unliftedTypeKindTyConName - || tc_name == unicodeStarKindTyConName + | tc `ifaceTyConHasKey` starKindTyConKey + || tc `ifaceTyConHasKey` unliftedTypeKindTyConKey + || tc `ifaceTyConHasKey` unicodeStarKindTyConKey = ppr tc -- Do not wrap *, # in parens | otherwise @@ -847,8 +1092,27 @@ ppr_iface_tc_app pp ctxt_prec tc tys where tc_name = ifaceTyConName tc -pprTuple :: TupleSort -> IfaceTyConInfo -> IfaceTcArgs -> SDoc -pprTuple sort info args +pprSum :: Arity -> IsPromoted -> IfaceTcArgs -> SDoc +pprSum _arity is_promoted args + = -- drop the RuntimeRep vars. + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + let tys = tcArgsIfaceTypes args + args' = drop (length tys `div` 2) tys + in pprPromotionQuoteI is_promoted + <> sumParens (pprWithBars (ppr_ty TopPrec) args') + +pprTuple :: TupleSort -> IsPromoted -> IfaceTcArgs -> SDoc +pprTuple ConstraintTuple IsNotPromoted ITC_Nil + = text "() :: Constraint" + +-- All promoted constructors have kind arguments +pprTuple sort IsPromoted args + = let tys = tcArgsIfaceTypes args + args' = drop (length tys `div` 2) tys + in pprPromotionQuoteI IsPromoted <> + tupleParens sort (pprWithCommas pprIfaceType args') + +pprTuple sort promoted args = -- drop the RuntimeRep vars. -- See Note [Unboxed tuple RuntimeRep vars] in TyCon let tys = tcArgsIfaceTypes args @@ -856,12 +1120,12 @@ pprTuple sort info args UnboxedTuple -> drop (length tys `div` 2) tys _ -> tys in - pprPromotionQuoteI info <> + pprPromotionQuoteI promoted <> tupleParens sort (pprWithCommas pprIfaceType args') -ppr_tylit :: IfaceTyLit -> SDoc -ppr_tylit (IfaceNumTyLit n) = integer n -ppr_tylit (IfaceStrTyLit n) = text (show n) +pprIfaceTyLit :: IfaceTyLit -> SDoc +pprIfaceTyLit (IfaceNumTyLit n) = integer n +pprIfaceTyLit (IfaceStrTyLit n) = text (show n) pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc pprIfaceCoercion = ppr_co TopPrec @@ -899,6 +1163,13 @@ ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2) text "UnsafeCo" <+> ppr r <+> pprParendIfaceType ty1 <+> pprParendIfaceType ty2 +ppr_co ctxt_prec (IfaceUnivCo (IfaceHoleProv u) _ _ _) + = maybeParen ctxt_prec TyConPrec $ + sdocWithDynFlags $ \dflags -> + if gopt Opt_PrintExplicitCoercions dflags + then braces $ ppr u + else braces $ text "a hole" + ppr_co _ (IfaceUnivCo _ _ ty1 ty2) = angleBrackets ( ppr ty1 <> comma <+> ppr ty2 ) @@ -944,11 +1215,12 @@ instance Outputable IfaceTyCon where ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc) pprPromotionQuote :: IfaceTyCon -> SDoc -pprPromotionQuote tc = pprPromotionQuoteI (ifaceTyConInfo tc) +pprPromotionQuote tc = + pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc -pprPromotionQuoteI :: IfaceTyConInfo -> SDoc -pprPromotionQuoteI NoIfaceTyConInfo = empty -pprPromotionQuoteI IfacePromotedDataCon = char '\'' +pprPromotionQuoteI :: IsPromoted -> SDoc +pprPromotionQuoteI IsNotPromoted = empty +pprPromotionQuoteI IsPromoted = char '\'' instance Outputable IfaceCoercion where ppr = pprIfaceCoercion @@ -960,18 +1232,42 @@ instance Binary IfaceTyCon where i <- get bh return (IfaceTyCon n i) +instance Binary IsPromoted where + put_ bh IsNotPromoted = putByte bh 0 + put_ bh IsPromoted = putByte bh 1 + + get bh = do + n <- getByte bh + case n of + 0 -> return IsNotPromoted + 1 -> return IsPromoted + _ -> fail "Binary(IsPromoted): fail)" + +instance Binary IfaceTyConSort where + put_ bh IfaceNormalTyCon = putByte bh 0 + put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort + put_ bh (IfaceSumTyCon arity) = putByte bh 2 >> put_ bh arity + put_ bh (IfaceEqualityTyCon hom) + | hom = putByte bh 3 + | otherwise = putByte bh 4 + + get bh = do + n <- getByte bh + case n of + 0 -> return IfaceNormalTyCon + 1 -> IfaceTupleTyCon <$> get bh <*> get bh + 2 -> IfaceSumTyCon <$> get bh + 3 -> return $ IfaceEqualityTyCon True + 4 -> return $ IfaceEqualityTyCon False + _ -> fail "Binary(IfaceTyConSort): fail" + instance Binary IfaceTyConInfo where - put_ bh NoIfaceTyConInfo = putByte bh 0 - put_ bh IfacePromotedDataCon = putByte bh 1 + put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s - get bh = - do i <- getByte bh - case i of - 0 -> return NoIfaceTyConInfo - _ -> return IfacePromotedDataCon + get bh = IfaceTyConInfo <$> get bh <*> get bh instance Outputable IfaceTyLit where - ppr = ppr_tylit + ppr = pprIfaceTyLit instance Binary IfaceTyLit where put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n @@ -1008,14 +1304,51 @@ instance Binary IfaceTcArgs where _ -> panic ("get IfaceTcArgs " ++ show c) ------------------- -pprIfaceContextArr :: Outputable a => [a] -> SDoc --- Prints "(C a, D b) =>", including the arrow -pprIfaceContextArr [] = empty -pprIfaceContextArr preds = pprIfaceContext preds <+> darrow -pprIfaceContext :: Outputable a => [a] -> SDoc +-- 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 TyOpPrec, 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. This is used when we want to +-- print a context in a type. +pprIfaceContextArr :: [IfacePredType] -> SDoc +pprIfaceContextArr [] = empty +pprIfaceContextArr [pred] = ppr_ty TyOpPrec pred <+> darrow +pprIfaceContextArr preds = + parens (fsep (punctuate comma (map ppr preds))) <+> darrow + +-- | Prints a context or @()@ if empty. This is used when, e.g., we want to +-- display a context in an error message. +pprIfaceContext :: [IfacePredType] -> SDoc pprIfaceContext [] = parens empty -pprIfaceContext [pred] = ppr pred -- No parens +pprIfaceContext [pred] = ppr_ty TyOpPrec pred pprIfaceContext preds = parens (fsep (punctuate comma (map ppr preds))) instance Binary IfaceType where @@ -1219,6 +1552,9 @@ instance Binary IfaceUnivCoProv where put_ bh (IfacePluginProv a) = do putByte bh 4 put_ bh a + put_ _ (IfaceHoleProv _) = + pprPanic "Binary(IfaceUnivCoProv) hit a hole" empty + -- See Note [Holes in IfaceUnivCoProv] get bh = do tag <- getByte bh @@ -1241,136 +1577,3 @@ instance Binary (DefMethSpec IfaceType) where case h of 0 -> return VanillaDM _ -> do { t <- get bh; return (GenericDM t) } - -{- -************************************************************************ -* * - Conversion from Type to IfaceType -* * -************************************************************************ --} - ----------------- -toIfaceTvBndr :: TyVar -> IfaceTvBndr -toIfaceTvBndr tyvar = ( occNameFS (getOccName tyvar) - , toIfaceKind (tyVarKind tyvar) - ) - -toIfaceIdBndr :: Id -> (IfLclName, IfaceType) -toIfaceIdBndr id = (occNameFS (getOccName id), toIfaceType (idType id)) - -toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr] -toIfaceTvBndrs = map toIfaceTvBndr - -toIfaceBndr :: Var -> IfaceBndr -toIfaceBndr var - | isId var = IfaceIdBndr (toIfaceIdBndr var) - | otherwise = IfaceTvBndr (toIfaceTvBndr var) - -toIfaceKind :: Type -> IfaceType -toIfaceKind = toIfaceType - ---------------------- -toIfaceType :: Type -> IfaceType --- Synonyms are retained in the interface type -toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv) -toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2) -toIfaceType (LitTy n) = IfaceLitTy (toIfaceTyLit n) -toIfaceType (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndr b) (toIfaceType t) -toIfaceType (FunTy t1 t2) - | isPredTy t1 = IfaceDFunTy (toIfaceType t1) (toIfaceType t2) - | otherwise = IfaceFunTy (toIfaceType t1) (toIfaceType t2) -toIfaceType (CastTy ty co) = IfaceCastTy (toIfaceType ty) (toIfaceCoercion co) -toIfaceType (CoercionTy co) = IfaceCoercionTy (toIfaceCoercion co) - -toIfaceType (TyConApp tc tys) -- Look for the two sorts of saturated tuple - | Just sort <- tyConTuple_maybe tc - , n_tys == arity - = IfaceTupleTy sort NoIfaceTyConInfo (toIfaceTcArgs tc tys) - - | Just dc <- isPromotedDataCon_maybe tc - , isTupleDataCon dc - , n_tys == 2*arity - = IfaceTupleTy BoxedTuple IfacePromotedDataCon (toIfaceTcArgs tc (drop arity tys)) - - | otherwise - = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgs tc tys) - where - arity = tyConArity tc - n_tys = length tys - -toIfaceTyVar :: TyVar -> FastString -toIfaceTyVar = occNameFS . getOccName - -toIfaceCoVar :: CoVar -> FastString -toIfaceCoVar = occNameFS . getOccName - -toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr -toIfaceForAllBndr (TvBndr v vis) = TvBndr (toIfaceTvBndr v) vis - ----------------- -toIfaceTyCon :: TyCon -> IfaceTyCon -toIfaceTyCon tc - = IfaceTyCon tc_name info - where - tc_name = tyConName tc - info | isPromotedDataCon tc = IfacePromotedDataCon - | otherwise = NoIfaceTyConInfo - -toIfaceTyCon_name :: Name -> IfaceTyCon -toIfaceTyCon_name n = IfaceTyCon n NoIfaceTyConInfo - -- Used for the "rough-match" tycon stuff, - -- where pretty-printing is not an issue - -toIfaceTyLit :: TyLit -> IfaceTyLit -toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x -toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x - ----------------- -toIfaceTypes :: [Type] -> [IfaceType] -toIfaceTypes ts = map toIfaceType ts - ----------------- -toIfaceContext :: ThetaType -> IfaceContext -toIfaceContext = toIfaceTypes - ----------------- -toIfaceCoercion :: Coercion -> IfaceCoercion -toIfaceCoercion (Refl r ty) = IfaceReflCo r (toIfaceType ty) -toIfaceCoercion (TyConAppCo r tc cos) - | tc `hasKey` funTyConKey - , [arg,res] <- cos = IfaceFunCo r (toIfaceCoercion arg) (toIfaceCoercion res) - | otherwise = IfaceTyConAppCo r (toIfaceTyCon tc) - (map toIfaceCoercion cos) -toIfaceCoercion (AppCo co1 co2) = IfaceAppCo (toIfaceCoercion co1) - (toIfaceCoercion co2) -toIfaceCoercion (ForAllCo tv k co) = IfaceForAllCo (toIfaceTvBndr tv) - (toIfaceCoercion k) - (toIfaceCoercion co) -toIfaceCoercion (CoVarCo cv) = IfaceCoVarCo (toIfaceCoVar cv) -toIfaceCoercion (AxiomInstCo con ind cos) - = IfaceAxiomInstCo (coAxiomName con) ind - (map toIfaceCoercion cos) -toIfaceCoercion (UnivCo p r t1 t2) = IfaceUnivCo (toIfaceUnivCoProv p) r - (toIfaceType t1) - (toIfaceType t2) -toIfaceCoercion (SymCo co) = IfaceSymCo (toIfaceCoercion co) -toIfaceCoercion (TransCo co1 co2) = IfaceTransCo (toIfaceCoercion co1) - (toIfaceCoercion co2) -toIfaceCoercion (NthCo d co) = IfaceNthCo d (toIfaceCoercion co) -toIfaceCoercion (LRCo lr co) = IfaceLRCo lr (toIfaceCoercion co) -toIfaceCoercion (InstCo co arg) = IfaceInstCo (toIfaceCoercion co) - (toIfaceCoercion arg) -toIfaceCoercion (CoherenceCo c1 c2) = IfaceCoherenceCo (toIfaceCoercion c1) - (toIfaceCoercion c2) -toIfaceCoercion (KindCo c) = IfaceKindCo (toIfaceCoercion c) -toIfaceCoercion (SubCo co) = IfaceSubCo (toIfaceCoercion co) -toIfaceCoercion (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co) - (map toIfaceCoercion cs) - -toIfaceUnivCoProv :: UnivCoProvenance -> IfaceUnivCoProv -toIfaceUnivCoProv UnsafeCoerceProv = IfaceUnsafeCoerceProv -toIfaceUnivCoProv (PhantomProv co) = IfacePhantomProv (toIfaceCoercion co) -toIfaceUnivCoProv (ProofIrrelProv co) = IfaceProofIrrelProv (toIfaceCoercion co) -toIfaceUnivCoProv (PluginProv str) = IfacePluginProv str -toIfaceUnivCoProv (HoleProv h) = pprPanic "toIfaceUnivCoProv hit a hole" (ppr h) diff --git a/compiler/iface/IfaceType.hs-boot b/compiler/iface/IfaceType.hs-boot new file mode 100644 index 0000000000..a030c553f6 --- /dev/null +++ b/compiler/iface/IfaceType.hs-boot @@ -0,0 +1,36 @@ +-- Exists to allow TyCoRep to import pretty-printers +module IfaceType where + +import Var (TyVarBndr, ArgFlag) +import TyCon (TyConBndrVis) +import BasicTypes (TyPrec) +import Outputable (Outputable, SDoc) +import FastString (FastString) + +type IfLclName = FastString +type IfaceKind = IfaceType +type IfacePredType = IfaceType + +data IfaceType +data IfaceTyCon +data IfaceTyLit +data IfaceCoercion +data IfaceTcArgs +type IfaceTvBndr = (IfLclName, IfaceKind) +type IfaceTyConBinder = TyVarBndr IfaceTvBndr TyConBndrVis +type IfaceForAllBndr = TyVarBndr IfaceTvBndr ArgFlag + +instance Outputable IfaceType + +pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc +pprIfaceSigmaType :: IfaceType -> SDoc +pprIfaceTyLit :: IfaceTyLit -> SDoc +pprIfaceForAll :: [IfaceForAllBndr] -> SDoc +pprIfaceTvBndr :: Bool -> IfaceTvBndr -> SDoc +pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc +pprIfaceContext :: [IfacePredType] -> SDoc +pprIfaceContextArr :: [IfacePredType] -> SDoc +pprIfaceTypeApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc +pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc +pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc +pprIfacePrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 9eac21c464..46514188d0 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -61,13 +61,11 @@ Basic idea: import IfaceSyn import BinFingerprint import LoadIface +import ToIface import FlagChecker import Desugar ( mkUsageInfo, mkUsedNames, mkDependencies ) import Id -import IdInfo -import Demand -import Coercion( tidyCo ) import Annotations import CoreSyn import Class @@ -75,7 +73,6 @@ import TyCon import CoAxiom import ConLike import DataCon -import PatSyn import Type import TcType import InstEnv @@ -110,7 +107,6 @@ import Fingerprint import Exception import UniqFM import UniqDFM -import MkId import Control.Monad import Data.Function @@ -1459,29 +1455,6 @@ dataConToIfaceDecl dataCon ifIdInfo = NoInfo } -------------------------- -patSynToIfaceDecl :: PatSyn -> IfaceDecl -patSynToIfaceDecl ps - = IfacePatSyn { ifName = getName $ ps - , ifPatMatcher = to_if_pr (patSynMatcher ps) - , ifPatBuilder = fmap to_if_pr (patSynBuilder ps) - , ifPatIsInfix = patSynIsInfix ps - , ifPatUnivBndrs = map toIfaceForAllBndr univ_bndrs' - , ifPatExBndrs = map toIfaceForAllBndr ex_bndrs' - , ifPatProvCtxt = tidyToIfaceContext env2 prov_theta - , ifPatReqCtxt = tidyToIfaceContext env2 req_theta - , ifPatArgs = map (tidyToIfaceType env2) args - , ifPatTy = tidyToIfaceType env2 rhs_ty - , ifFieldLabels = (patSynFieldLabels ps) - } - where - (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps - univ_bndrs = patSynUnivTyVarBinders ps - ex_bndrs = patSynExTyVarBinders ps - (env1, univ_bndrs') = tidyTyVarBinders emptyTidyEnv univ_bndrs - (env2, ex_bndrs') = tidyTyVarBinders env1 ex_bndrs - to_if_pr (id, needs_dummy) = (idName id, needs_dummy) - --------------------------- coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl -- We *do* tidy Axioms, because they are not (and cannot -- conveniently be) built in tidy form @@ -1658,15 +1631,6 @@ tyConToIfaceDecl env tycon [] -> False ifaceFields flds = map flLabel $ dFsEnvElts flds -toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang -toIfaceBang _ HsLazy = IfNoBang -toIfaceBang _ (HsUnpack Nothing) = IfUnpack -toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co)) -toIfaceBang _ HsStrict = IfStrict - -toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang -toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang - classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl) classToIfaceDecl env clas = ( env1 @@ -1713,20 +1677,6 @@ classToIfaceDecl env clas ,map (tidyTyVar env1) tvs2) -------------------------- -tidyToIfaceType :: TidyEnv -> Type -> IfaceType -tidyToIfaceType env ty = toIfaceType (tidyType env ty) - -tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceTcArgs -tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys) - -tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext -tidyToIfaceContext env theta = map (tidyToIfaceType env) theta - -toIfaceTyVarBinder :: TyVarBndr TyVar vis -> TyVarBndr IfaceTvBndr vis -toIfaceTyVarBinder (TvBndr tv vis) = TvBndr (toIfaceTvBndr tv) vis - -toIfaceTyVarBinders :: [TyVarBndr TyVar vis] -> [TyVarBndr IfaceTvBndr vis] -toIfaceTyVarBinders = map toIfaceTyVarBinder tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder) -- If the type variable "binder" is in scope, don't re-bind it @@ -1788,94 +1738,6 @@ famInstToIfaceFamInst (FamInst { fi_axiom = axiom, = chooseOrphanAnchor lhs_names -------------------------- -toIfaceLetBndr :: Id -> IfaceLetBndr -toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) - (toIfaceType (idType id)) - (toIfaceIdInfo (idInfo id)) - -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr - -- has left on the Id. See Note [IdInfo on nested let-bindings] in IfaceSyn - ---------------------------t -toIfaceIdDetails :: IdDetails -> IfaceIdDetails -toIfaceIdDetails VanillaId = IfVanillaId -toIfaceIdDetails (DFunId {}) = IfDFunId -toIfaceIdDetails (RecSelId { sel_naughty = n - , sel_tycon = tc }) = - let iface = case tc of - RecSelData ty_con -> Left (toIfaceTyCon ty_con) - RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn) - in IfRecSelId iface n - - -- The remaining cases are all "implicit Ids" which don't - -- appear in interface files at all -toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) - IfVanillaId -- Unexpected; the other - -toIfaceIdInfo :: IdInfo -> IfaceIdInfo -toIfaceIdInfo id_info - = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, - inline_hsinfo, unfold_hsinfo] of - [] -> NoInfo - infos -> HasInfo infos - -- NB: strictness and arity must appear in the list before unfolding - -- See TcIface.tcUnfolding - where - ------------ Arity -------------- - arity_info = arityInfo id_info - arity_hsinfo | arity_info == 0 = Nothing - | otherwise = Just (HsArity arity_info) - - ------------ Caf Info -------------- - caf_info = cafInfo id_info - caf_hsinfo = case caf_info of - NoCafRefs -> Just HsNoCafRefs - _other -> Nothing - - ------------ Strictness -------------- - -- No point in explicitly exporting TopSig - sig_info = strictnessInfo id_info - strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info) - | otherwise = Nothing - - ------------ Unfolding -------------- - unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) - loop_breaker = isStrongLoopBreaker (occInfo id_info) - - ------------ Inline prag -------------- - inline_prag = inlinePragInfo id_info - inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing - | otherwise = Just (HsInline inline_prag) - --------------------------- -toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem -toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs - , uf_src = src - , uf_guidance = guidance }) - = Just $ HsUnfold lb $ - case src of - InlineStable - -> case guidance of - UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } - -> IfInlineRule arity unsat_ok boring_ok if_rhs - _other -> IfCoreUnfold True if_rhs - InlineCompulsory -> IfCompulsory if_rhs - InlineRhs -> IfCoreUnfold False if_rhs - -- Yes, even if guidance is UnfNever, expose the unfolding - -- If we didn't want to expose the unfolding, TidyPgm would - -- have stuck in NoUnfolding. For supercompilation we want - -- to see that unfolding! - where - if_rhs = toIfaceExpr rhs - -toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args }) - = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args))) - -- No need to serialise the data constructor; - -- we can recover it from the type of the dfun - -toIfUnfolding _ _ - = Nothing - --------------------------- coreRuleToIfaceRule :: CoreRule -> IfaceRule coreRuleToIfaceRule (BuiltinRule { ru_fn = fn}) = pprTrace "toHsRule: builtin" (ppr fn) $ @@ -1909,89 +1771,6 @@ bogusIfaceRule id_name ifRuleAuto = True } --------------------- -toIfaceExpr :: CoreExpr -> IfaceExpr -toIfaceExpr (Var v) = toIfaceVar v -toIfaceExpr (Lit l) = IfaceLit l -toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) -toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co) -toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b) -toIfaceExpr (App f a) = toIfaceApp f [a] -toIfaceExpr (Case s x ty as) - | null as = IfaceECase (toIfaceExpr s) (toIfaceType ty) - | otherwise = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as) -toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) -toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co) -toIfaceExpr (Tick t e) - | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e) - | otherwise = toIfaceExpr e - -toIfaceOneShot :: Id -> IfaceOneShot -toIfaceOneShot id | isId id - , OneShotLam <- oneShotInfo (idInfo id) - = IfaceOneShot - | otherwise - = IfaceNoOneShot - ---------------------- -toIfaceTickish :: Tickish Id -> Maybe IfaceTickish -toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push) -toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix) -toIfaceTickish (SourceNote src names) = Just (IfaceSource src names) -toIfaceTickish (Breakpoint {}) = Nothing - -- Ignore breakpoints, since they are relevant only to GHCi, and - -- should not be serialised (Trac #8333) - ---------------------- -toIfaceBind :: Bind Id -> IfaceBinding -toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r) -toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs] - ---------------------- -toIfaceAlt :: (AltCon, [Var], CoreExpr) - -> (IfaceConAlt, [FastString], IfaceExpr) -toIfaceAlt (c,bs,r) = (toIfaceCon c, map getOccFS bs, toIfaceExpr r) - ---------------------- -toIfaceCon :: AltCon -> IfaceConAlt -toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc) -toIfaceCon (LitAlt l) = IfaceLitAlt l -toIfaceCon DEFAULT = IfaceDefault - ---------------------- -toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr -toIfaceApp (App f a) as = toIfaceApp f (a:as) -toIfaceApp (Var v) as - = case isDataConWorkId_maybe v of - -- We convert the *worker* for tuples into IfaceTuples - Just dc | saturated - , Just tup_sort <- tyConTuple_maybe tc - -> IfaceTuple tup_sort tup_args - where - val_args = dropWhile isTypeArg as - saturated = val_args `lengthIs` idArity v - tup_args = map toIfaceExpr val_args - tc = dataConTyCon dc - - _ -> mkIfaceApps (toIfaceVar v) as - -toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as - -mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr -mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as - ---------------------- -toIfaceVar :: Id -> IfaceExpr -toIfaceVar v - | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) - -- Foreign calls have special syntax - | isBootUnfolding (idUnfolding v) - = IfaceApp (IfaceApp (IfaceExt noinlineIdName) (IfaceType (toIfaceType (idType v)))) - (IfaceExt name) -- don't use mkIfaceApps, or infinite loop - -- See Note [Inlining and hs-boot files] - | isExternalName name = IfaceExt name - | otherwise = IfaceLcl (getOccFS name) - where name = idName v - {- Note [Inlining and hs-boot files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 1ad5114b84..98a5f2768c 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -1114,16 +1114,16 @@ tcIfaceType = go go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co -tcIfaceTupleTy :: TupleSort -> IfaceTyConInfo -> IfaceTcArgs -> IfL Type -tcIfaceTupleTy sort info args +tcIfaceTupleTy :: TupleSort -> IsPromoted -> IfaceTcArgs -> IfL Type +tcIfaceTupleTy sort is_promoted args = do { args' <- tcIfaceTcArgs args ; let arity = length args' ; base_tc <- tcTupleTyCon True sort arity - ; case info of - NoIfaceTyConInfo + ; case is_promoted of + IsNotPromoted -> return (mkTyConApp base_tc args') - IfacePromotedDataCon + IsPromoted -> do { let tc = promoteDataCon (tyConSingleDataCon base_tc) kind_args = map typeKind args' ; return (mkTyConApp tc (kind_args ++ args')) } } @@ -1206,6 +1206,8 @@ tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str +tcIfaceUnivCoProv (IfaceHoleProv _) = + pprPanic "tcIfaceUnivCoProv" (text "holes can't occur in interface files") {- ************************************************************************ @@ -1596,9 +1598,9 @@ tcIfaceTyConByName name tcIfaceTyCon :: IfaceTyCon -> IfL TyCon tcIfaceTyCon (IfaceTyCon name info) = do { thing <- tcIfaceGlobal name - ; return $ case info of - NoIfaceTyConInfo -> tyThingTyCon thing - IfacePromotedDataCon -> promoteDataCon $ tyThingDataCon thing } + ; return $ case ifaceTyConIsPromoted info of + IsNotPromoted -> tyThingTyCon thing + IsPromoted -> promoteDataCon $ tyThingDataCon thing } tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched) tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name diff --git a/compiler/iface/ToIface.hs b/compiler/iface/ToIface.hs new file mode 100644 index 0000000000..48a95a97b2 --- /dev/null +++ b/compiler/iface/ToIface.hs @@ -0,0 +1,497 @@ +{-# LANGUAGE CPP #-} + +-- | Functions for converting Core things to interface file things. +module ToIface + ( -- * Binders + toIfaceTvBndr + , toIfaceTvBndrs + , toIfaceIdBndr + , toIfaceBndr + , toIfaceForAllBndr + , toIfaceTyVarBinders + , toIfaceTyVar + -- * Types + , toIfaceType + , toIfaceKind + , toIfaceTcArgs + , toIfaceTyCon + , toIfaceTyCon_name + , toIfaceTyLit + -- * Tidying types + , tidyToIfaceType + , tidyToIfaceContext + , tidyToIfaceTcArgs + -- * Coercions + , toIfaceCoercion + -- * Pattern synonyms + , patSynToIfaceDecl + -- * Expressions + , toIfaceExpr + , toIfaceBang + , toIfaceSrcBang + , toIfaceLetBndr + , toIfaceIdDetails + , toIfaceIdInfo + , toIfUnfolding + , toIfaceOneShot + , toIfaceTickish + , toIfaceBind + , toIfaceAlt + , toIfaceCon + , toIfaceApp + , toIfaceVar + ) where + +#include "HsVersions.h" + +import IfaceSyn +import DataCon +import Id +import IdInfo +import CoreSyn +import TyCon hiding ( pprPromotionQuote ) +import CoAxiom +import TysPrim ( eqPrimTyCon, eqReprPrimTyCon ) +import TysWiredIn ( heqTyCon ) +import MkId ( noinlineIdName ) +import PrelNames +import Name +import BasicTypes +import Type +import PatSyn +import Outputable +import FastString +import Util +import Var +import VarEnv +import TyCoRep +import Demand ( isTopSig ) + +import Data.Maybe ( catMaybes ) + +---------------- +toIfaceTvBndr :: TyVar -> IfaceTvBndr +toIfaceTvBndr tyvar = ( occNameFS (getOccName tyvar) + , toIfaceKind (tyVarKind tyvar) + ) + +toIfaceIdBndr :: Id -> (IfLclName, IfaceType) +toIfaceIdBndr id = (occNameFS (getOccName id), toIfaceType (idType id)) + +toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr] +toIfaceTvBndrs = map toIfaceTvBndr + +toIfaceBndr :: Var -> IfaceBndr +toIfaceBndr var + | isId var = IfaceIdBndr (toIfaceIdBndr var) + | otherwise = IfaceTvBndr (toIfaceTvBndr var) + +toIfaceTyVarBinder :: TyVarBndr TyVar vis -> TyVarBndr IfaceTvBndr vis +toIfaceTyVarBinder (TvBndr tv vis) = TvBndr (toIfaceTvBndr tv) vis + +toIfaceTyVarBinders :: [TyVarBndr TyVar vis] -> [TyVarBndr IfaceTvBndr vis] +toIfaceTyVarBinders = map toIfaceTyVarBinder + +{- +************************************************************************ +* * + Conversion from Type to IfaceType +* * +************************************************************************ +-} + +toIfaceKind :: Type -> IfaceType +toIfaceKind = toIfaceType + +--------------------- +toIfaceType :: Type -> IfaceType +-- Synonyms are retained in the interface type +toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv) +toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2) +toIfaceType (LitTy n) = IfaceLitTy (toIfaceTyLit n) +toIfaceType (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndr b) (toIfaceType t) +toIfaceType (FunTy t1 t2) + | isPredTy t1 = IfaceDFunTy (toIfaceType t1) (toIfaceType t2) + | otherwise = IfaceFunTy (toIfaceType t1) (toIfaceType t2) +toIfaceType (CastTy ty co) = IfaceCastTy (toIfaceType ty) (toIfaceCoercion co) +toIfaceType (CoercionTy co) = IfaceCoercionTy (toIfaceCoercion co) + +toIfaceType (TyConApp tc tys) + -- tuples + | Just sort <- tyConTuple_maybe tc + , n_tys == arity + = IfaceTupleTy sort IsNotPromoted (toIfaceTcArgs tc tys) + + | Just dc <- isPromotedDataCon_maybe tc + , isTupleDataCon dc + , n_tys == 2*arity + = IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgs tc (drop arity tys)) + + -- type equalities: see Note [Equality predicates in IfaceType] + | tyConName tc == eqTyConName + = let info = IfaceTyConInfo IsNotPromoted (IfaceEqualityTyCon True) + in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgs tc tys) + + | tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ] + , [k1, k2, _t1, _t2] <- tys + = let homogeneous = k1 `eqType` k2 + info = IfaceTyConInfo IsNotPromoted (IfaceEqualityTyCon homogeneous) + in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgs tc tys) + + -- other applications + | otherwise + = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgs tc tys) + where + arity = tyConArity tc + n_tys = length tys + +toIfaceTyVar :: TyVar -> FastString +toIfaceTyVar = occNameFS . getOccName + +toIfaceCoVar :: CoVar -> FastString +toIfaceCoVar = occNameFS . getOccName + +toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr +toIfaceForAllBndr (TvBndr v vis) = TvBndr (toIfaceTvBndr v) vis + +---------------- +toIfaceTyCon :: TyCon -> IfaceTyCon +toIfaceTyCon tc + = IfaceTyCon tc_name info + where + tc_name = tyConName tc + info = IfaceTyConInfo promoted sort + promoted | isPromotedDataCon tc = IsPromoted + | otherwise = IsNotPromoted + + tupleSort :: TyCon -> Maybe IfaceTyConSort + tupleSort tc' = + case tyConTuple_maybe tc' of + Just UnboxedTuple -> let arity = tyConArity tc' `div` 2 + in Just $ IfaceTupleTyCon arity UnboxedTuple + Just sort -> let arity = tyConArity tc' + in Just $ IfaceTupleTyCon arity sort + Nothing -> Nothing + + sort + | Just tsort <- tupleSort tc = tsort + + | Just dcon <- isPromotedDataCon_maybe tc + , let tc' = dataConTyCon dcon + , Just tsort <- tupleSort tc' = tsort + + | isUnboxedSumTyCon tc + , Just cons <- isDataSumTyCon_maybe tc = IfaceSumTyCon (length cons) + + | otherwise = IfaceNormalTyCon + + +toIfaceTyCon_name :: Name -> IfaceTyCon +toIfaceTyCon_name n = IfaceTyCon n info + where info = IfaceTyConInfo IsNotPromoted IfaceNormalTyCon + -- Used for the "rough-match" tycon stuff, + -- where pretty-printing is not an issue + +toIfaceTyLit :: TyLit -> IfaceTyLit +toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x +toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x + +---------------- +toIfaceCoercion :: Coercion -> IfaceCoercion +toIfaceCoercion (Refl r ty) = IfaceReflCo r (toIfaceType ty) +toIfaceCoercion (TyConAppCo r tc cos) + | tc `hasKey` funTyConKey + , [arg,res] <- cos = IfaceFunCo r (toIfaceCoercion arg) (toIfaceCoercion res) + | otherwise = IfaceTyConAppCo r (toIfaceTyCon tc) + (map toIfaceCoercion cos) +toIfaceCoercion (AppCo co1 co2) = IfaceAppCo (toIfaceCoercion co1) + (toIfaceCoercion co2) +toIfaceCoercion (ForAllCo tv k co) = IfaceForAllCo (toIfaceTvBndr tv) + (toIfaceCoercion k) + (toIfaceCoercion co) +toIfaceCoercion (CoVarCo cv) = IfaceCoVarCo (toIfaceCoVar cv) +toIfaceCoercion (AxiomInstCo con ind cos) + = IfaceAxiomInstCo (coAxiomName con) ind + (map toIfaceCoercion cos) +toIfaceCoercion (UnivCo p r t1 t2) = IfaceUnivCo (toIfaceUnivCoProv p) r + (toIfaceType t1) + (toIfaceType t2) +toIfaceCoercion (SymCo co) = IfaceSymCo (toIfaceCoercion co) +toIfaceCoercion (TransCo co1 co2) = IfaceTransCo (toIfaceCoercion co1) + (toIfaceCoercion co2) +toIfaceCoercion (NthCo d co) = IfaceNthCo d (toIfaceCoercion co) +toIfaceCoercion (LRCo lr co) = IfaceLRCo lr (toIfaceCoercion co) +toIfaceCoercion (InstCo co arg) = IfaceInstCo (toIfaceCoercion co) + (toIfaceCoercion arg) +toIfaceCoercion (CoherenceCo c1 c2) = IfaceCoherenceCo (toIfaceCoercion c1) + (toIfaceCoercion c2) +toIfaceCoercion (KindCo c) = IfaceKindCo (toIfaceCoercion c) +toIfaceCoercion (SubCo co) = IfaceSubCo (toIfaceCoercion co) +toIfaceCoercion (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co) + (map toIfaceCoercion cs) + +toIfaceUnivCoProv :: UnivCoProvenance -> IfaceUnivCoProv +toIfaceUnivCoProv UnsafeCoerceProv = IfaceUnsafeCoerceProv +toIfaceUnivCoProv (PhantomProv co) = IfacePhantomProv (toIfaceCoercion co) +toIfaceUnivCoProv (ProofIrrelProv co) = IfaceProofIrrelProv (toIfaceCoercion co) +toIfaceUnivCoProv (PluginProv str) = IfacePluginProv str +toIfaceUnivCoProv (HoleProv h) = IfaceHoleProv (chUnique h) + +toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs +-- See Note [Suppressing invisible arguments] +toIfaceTcArgs tc ty_args + = go (mkEmptyTCvSubst in_scope) (tyConKind tc) ty_args + where + in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) + + go _ _ [] = ITC_Nil + go env ty ts + | Just ty' <- coreView ty + = go env ty' ts + go env (ForAllTy (TvBndr tv vis) res) (t:ts) + | isVisibleArgFlag vis = ITC_Vis t' ts' + | otherwise = ITC_Invis t' ts' + where + t' = toIfaceType t + ts' = go (extendTvSubst env tv t) res ts + + go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps + = ITC_Vis (toIfaceType t) (go env res ts) + + go env (TyVarTy tv) ts + | Just ki <- lookupTyVar env tv = go env ki ts + go env kind (t:ts) = WARN( True, ppr tc $$ ppr (tyConKind tc) $$ ppr ty_args ) + ITC_Vis (toIfaceType t) (go env kind ts) -- Ill-kinded + +tidyToIfaceType :: TidyEnv -> Type -> IfaceType +tidyToIfaceType env ty = toIfaceType (tidyType env ty) + +tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceTcArgs +tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys) + +tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext +tidyToIfaceContext env theta = map (tidyToIfaceType env) theta + +{- +************************************************************************ +* * + Conversion of pattern synonyms +* * +************************************************************************ +-} + +patSynToIfaceDecl :: PatSyn -> IfaceDecl +patSynToIfaceDecl ps + = IfacePatSyn { ifName = getName $ ps + , ifPatMatcher = to_if_pr (patSynMatcher ps) + , ifPatBuilder = fmap to_if_pr (patSynBuilder ps) + , ifPatIsInfix = patSynIsInfix ps + , ifPatUnivBndrs = map toIfaceForAllBndr univ_bndrs' + , ifPatExBndrs = map toIfaceForAllBndr ex_bndrs' + , ifPatProvCtxt = tidyToIfaceContext env2 prov_theta + , ifPatReqCtxt = tidyToIfaceContext env2 req_theta + , ifPatArgs = map (tidyToIfaceType env2) args + , ifPatTy = tidyToIfaceType env2 rhs_ty + , ifFieldLabels = (patSynFieldLabels ps) + } + where + (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps + univ_bndrs = patSynUnivTyVarBinders ps + ex_bndrs = patSynExTyVarBinders ps + (env1, univ_bndrs') = tidyTyVarBinders emptyTidyEnv univ_bndrs + (env2, ex_bndrs') = tidyTyVarBinders env1 ex_bndrs + to_if_pr (id, needs_dummy) = (idName id, needs_dummy) + +{- +************************************************************************ +* * + Conversion of other things +* * +************************************************************************ +-} + +toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang +toIfaceBang _ HsLazy = IfNoBang +toIfaceBang _ (HsUnpack Nothing) = IfUnpack +toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co)) +toIfaceBang _ HsStrict = IfStrict + +toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang +toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang + +toIfaceLetBndr :: Id -> IfaceLetBndr +toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) + (toIfaceType (idType id)) + (toIfaceIdInfo (idInfo id)) + -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr + -- has left on the Id. See Note [IdInfo on nested let-bindings] in IfaceSyn + +toIfaceIdDetails :: IdDetails -> IfaceIdDetails +toIfaceIdDetails VanillaId = IfVanillaId +toIfaceIdDetails (DFunId {}) = IfDFunId +toIfaceIdDetails (RecSelId { sel_naughty = n + , sel_tycon = tc }) = + let iface = case tc of + RecSelData ty_con -> Left (toIfaceTyCon ty_con) + RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn) + in IfRecSelId iface n + + -- The remaining cases are all "implicit Ids" which don't + -- appear in interface files at all +toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) + IfVanillaId -- Unexpected; the other + +toIfaceIdInfo :: IdInfo -> IfaceIdInfo +toIfaceIdInfo id_info + = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, + inline_hsinfo, unfold_hsinfo] of + [] -> NoInfo + infos -> HasInfo infos + -- NB: strictness and arity must appear in the list before unfolding + -- See TcIface.tcUnfolding + where + ------------ Arity -------------- + arity_info = arityInfo id_info + arity_hsinfo | arity_info == 0 = Nothing + | otherwise = Just (HsArity arity_info) + + ------------ Caf Info -------------- + caf_info = cafInfo id_info + caf_hsinfo = case caf_info of + NoCafRefs -> Just HsNoCafRefs + _other -> Nothing + + ------------ Strictness -------------- + -- No point in explicitly exporting TopSig + sig_info = strictnessInfo id_info + strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info) + | otherwise = Nothing + + ------------ Unfolding -------------- + unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) + loop_breaker = isStrongLoopBreaker (occInfo id_info) + + ------------ Inline prag -------------- + inline_prag = inlinePragInfo id_info + inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing + | otherwise = Just (HsInline inline_prag) + +-------------------------- +toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem +toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs + , uf_src = src + , uf_guidance = guidance }) + = Just $ HsUnfold lb $ + case src of + InlineStable + -> case guidance of + UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } + -> IfInlineRule arity unsat_ok boring_ok if_rhs + _other -> IfCoreUnfold True if_rhs + InlineCompulsory -> IfCompulsory if_rhs + InlineRhs -> IfCoreUnfold False if_rhs + -- Yes, even if guidance is UnfNever, expose the unfolding + -- If we didn't want to expose the unfolding, TidyPgm would + -- have stuck in NoUnfolding. For supercompilation we want + -- to see that unfolding! + where + if_rhs = toIfaceExpr rhs + +toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args))) + -- No need to serialise the data constructor; + -- we can recover it from the type of the dfun + +toIfUnfolding _ _ + = Nothing + +{- +************************************************************************ +* * + Conversion of expressions +* * +************************************************************************ +-} + +toIfaceExpr :: CoreExpr -> IfaceExpr +toIfaceExpr (Var v) = toIfaceVar v +toIfaceExpr (Lit l) = IfaceLit l +toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) +toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co) +toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b) +toIfaceExpr (App f a) = toIfaceApp f [a] +toIfaceExpr (Case s x ty as) + | null as = IfaceECase (toIfaceExpr s) (toIfaceType ty) + | otherwise = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as) +toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) +toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co) +toIfaceExpr (Tick t e) + | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e) + | otherwise = toIfaceExpr e + +toIfaceOneShot :: Id -> IfaceOneShot +toIfaceOneShot id | isId id + , OneShotLam <- oneShotInfo (idInfo id) + = IfaceOneShot + | otherwise + = IfaceNoOneShot + +--------------------- +toIfaceTickish :: Tickish Id -> Maybe IfaceTickish +toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push) +toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix) +toIfaceTickish (SourceNote src names) = Just (IfaceSource src names) +toIfaceTickish (Breakpoint {}) = Nothing + -- Ignore breakpoints, since they are relevant only to GHCi, and + -- should not be serialised (Trac #8333) + +--------------------- +toIfaceBind :: Bind Id -> IfaceBinding +toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r) +toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs] + +--------------------- +toIfaceAlt :: (AltCon, [Var], CoreExpr) + -> (IfaceConAlt, [FastString], IfaceExpr) +toIfaceAlt (c,bs,r) = (toIfaceCon c, map getOccFS bs, toIfaceExpr r) + +--------------------- +toIfaceCon :: AltCon -> IfaceConAlt +toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc) +toIfaceCon (LitAlt l) = IfaceLitAlt l +toIfaceCon DEFAULT = IfaceDefault + +--------------------- +toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr +toIfaceApp (App f a) as = toIfaceApp f (a:as) +toIfaceApp (Var v) as + = case isDataConWorkId_maybe v of + -- We convert the *worker* for tuples into IfaceTuples + Just dc | saturated + , Just tup_sort <- tyConTuple_maybe tc + -> IfaceTuple tup_sort tup_args + where + val_args = dropWhile isTypeArg as + saturated = val_args `lengthIs` idArity v + tup_args = map toIfaceExpr val_args + tc = dataConTyCon dc + + _ -> mkIfaceApps (toIfaceVar v) as + +toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as + +mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr +mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as + +--------------------- +toIfaceVar :: Id -> IfaceExpr +toIfaceVar v + | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) + -- Foreign calls have special syntax + | isBootUnfolding (idUnfolding v) + = IfaceApp (IfaceApp (IfaceExt noinlineIdName) (IfaceType (toIfaceType (idType v)))) + (IfaceExt name) -- don't use mkIfaceApps, or infinite loop + -- See Note [Inlining and hs-boot files] + | isExternalName name = IfaceExt name + | otherwise = IfaceLcl (getOccFS name) + where name = idName v diff --git a/compiler/iface/ToIface.hs-boot b/compiler/iface/ToIface.hs-boot new file mode 100644 index 0000000000..bf6c120d8e --- /dev/null +++ b/compiler/iface/ToIface.hs-boot @@ -0,0 +1,15 @@ +module ToIface where + +import {-# SOURCE #-} TyCoRep +import {-# SOURCE #-} IfaceType +import Var ( TyVar, TyVarBinder ) +import TyCon ( TyCon ) + +-- For TyCoRep +toIfaceType :: Type -> IfaceType +toIfaceTyLit :: TyLit -> IfaceTyLit +toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr +toIfaceTvBndr :: TyVar -> IfaceTvBndr +toIfaceTyCon :: TyCon -> IfaceTyCon +toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs +toIfaceCoercion :: Coercion -> IfaceCoercion diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 8eb77efe2d..3345ddfe22 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -219,7 +219,7 @@ module GHC ( pprParendType, pprTypeApp, Kind, PredType, - ThetaType, pprForAll, pprForAllImplicit, pprThetaArrowTy, + ThetaType, pprForAll, pprThetaArrowTy, -- ** Entities TyThing(..), diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index d3ba85e6e3..1c47922a36 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -102,7 +102,7 @@ module TysWiredIn ( -- * RuntimeRep and friends runtimeRepTyCon, vecCountTyCon, vecElemTyCon, - runtimeRepTy, ptrRepLiftedTy, + runtimeRepTy, ptrRepLiftedTy, ptrRepLiftedDataCon, ptrRepLiftedDataConTyCon, vecRepDataConTyCon, ptrRepUnliftedDataConTyCon, @@ -1161,9 +1161,12 @@ int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon) vecElemDataCons +ptrRepLiftedDataConTyCon :: TyCon +ptrRepLiftedDataConTyCon = promoteDataCon ptrRepLiftedDataCon + -- The type ('PtrRepLifted) ptrRepLiftedTy :: Type -ptrRepLiftedTy = mkTyConTy $ promoteDataCon ptrRepLiftedDataCon +ptrRepLiftedTy = mkTyConTy ptrRepLiftedDataConTyCon {- ********************************************************************* * * diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/prelude/TysWiredIn.hs-boot index b759644448..7b7229c977 100644 --- a/compiler/prelude/TysWiredIn.hs-boot +++ b/compiler/prelude/TysWiredIn.hs-boot @@ -19,7 +19,7 @@ runtimeRepTyCon, vecCountTyCon, vecElemTyCon :: TyCon runtimeRepTy :: Type ptrRepLiftedTy :: Type -ptrRepUnliftedDataConTyCon, vecRepDataConTyCon :: TyCon +ptrRepLiftedDataConTyCon, ptrRepUnliftedDataConTyCon, vecRepDataConTyCon :: TyCon voidRepDataConTy, intRepDataConTy, wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy, diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 837f4e8a2d..7c1857a779 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -657,8 +657,9 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred ; traceTc "Deriving strategy (deriving clause)" $ vcat [ppr deriv_strat, ppr deriv_pred] - ; traceTc "derivTyData1" (vcat [ pprTvBndrs tvs, ppr tc, ppr tc_args, ppr deriv_pred - , pprTvBndrs (tyCoVarsOfTypesList tc_args) + ; traceTc "derivTyData1" (vcat [ pprTyVars tvs, ppr tc, ppr tc_args + , ppr deriv_pred + , pprTyVars (tyCoVarsOfTypesList tc_args) , ppr n_args_to_keep, ppr n_args_to_drop , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match , ppr final_tc_args, ppr final_cls_tys ]) diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs index 63ff90489f..109e6347e7 100644 --- a/compiler/typecheck/TcDerivInfer.hs +++ b/compiler/typecheck/TcDerivInfer.hs @@ -526,7 +526,7 @@ simplifyDeriv pred tvs theta ; (wanted, tclvl) <- pushTcLevelM (mapM mk_ct theta) ; traceTc "simplifyDeriv inputs" $ - vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ] + vcat [ pprTyVars tvs $$ ppr theta $$ ppr wanted, doc ] -- Simplify the constraints ; residual_wanted <- simplifyWantedsTcM wanted -- Result is zonked diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 783b6efe78..d73c94f046 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -194,7 +194,7 @@ report_unsolved mb_binds_var err_as_warn type_errors expr_holes free_tvs = tyCoVarsOfWCList wanted ; traceTc "reportUnsolved (after zonking and tidying):" $ - vcat [ pprTvBndrs free_tvs + vcat [ pprTyVars free_tvs , ppr wanted ] ; warn_redundant <- woptM Opt_WarnRedundantConstraints diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 9e7eed18f7..2632fd19fe 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -1207,7 +1207,7 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald kind = tyVarKind tv ; MASSERT2( vis == Specified , (vcat [ ppr fun_ty, ppr upsilon_ty, ppr tvb - , ppr inner_ty, pprTvBndr tv + , ppr inner_ty, pprTyVar tv , ppr vis ]) ) ; ty_arg <- tcHsTypeApp hs_ty_arg kind ; let insted_ty = substTyWithUnchecked [tv] [ty_arg] inner_ty diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 6e6bcd07a9..8fb5d16862 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -1468,7 +1468,7 @@ tcExplicitTKBndrsX new_tv orig_hs_tvs thing_inside ; traceTc "tcExplicitTKBndrs" $ vcat [ text "Hs vars:" <+> ppr orig_hs_tvs - , text "tvs:" <+> sep (map pprTvBndr tvs) ] + , text "tvs:" <+> sep (map pprTyVar tvs) ] ; return (result, bound_tvs `unionVarSet` mkVarSet tvs) } diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index 22556ed2de..9a94eef851 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -396,7 +396,7 @@ runSolverPipeline pipeline workItem ContinueWith ct -> do { traceFireTcS (ctEvidence ct) (text "Kept as inert") ; traceTcS "End solver pipeline (kept as inert) }" $ vcat [ text "final_item =" <+> ppr ct - , pprTvBndrs $ tyCoVarsOfCtList ct + , pprTyVars $ tyCoVarsOfCtList ct , text "inerts =" <+> ppr final_is] ; addInertCan ct } } diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index 0892f642d3..af87483a6d 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -1411,7 +1411,7 @@ zonkTcTyCoVarBndr :: TcTyCoVar -> TcM TcTyCoVar -- unification variables. zonkTcTyCoVarBndr tyvar -- can't use isCoVar, because it looks at a TyCon. Argh. - = ASSERT2( isImmutableTyVar tyvar || (not $ isTyVar tyvar), pprTvBndr tyvar ) + = ASSERT2( isImmutableTyVar tyvar || (not $ isTyVar tyvar), pprTyVar tyvar ) updateTyVarKindM zonkTcType tyvar -- | Zonk a TyBinder diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 9a5fd7d8cb..b1d444aee5 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -29,6 +29,7 @@ import RdrName import TcEnv import TcMType import TcValidity( arityErr ) +import Type ( pprTyVars ) import TcType import TcUnify import TcHsType @@ -757,11 +758,11 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside arg_tys' = substTys tenv arg_tys ; traceTc "tcConPat" (vcat [ ppr con_name - , pprTvBndrs univ_tvs - , pprTvBndrs ex_tvs + , pprTyVars univ_tvs + , pprTyVars ex_tvs , ppr eq_spec , ppr theta - , pprTvBndrs ex_tvs' + , pprTyVars ex_tvs' , ppr ctxt_res_tys , ppr arg_tys' , ppr arg_pats ]) diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index c3d18978b4..9c4bc75ab2 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -2174,7 +2174,7 @@ instance Outputable Implication where , ic_binds = binds, ic_info = info }) = hang (text "Implic" <+> lbrace) 2 (sep [ text "TcLevel =" <+> ppr tclvl - , text "Skolems =" <+> pprTvBndrs skols + , text "Skolems =" <+> pprTyVars skols , text "No-eqs =" <+> ppr no_eqs , text "Status =" <+> ppr status , hang (text "Given =") 2 (pprEvVars given) diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 0b471d2b2a..c009bc91d9 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -1129,7 +1129,7 @@ tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_,_) mb_clsinfo ; (ze, tvs') <- zonkTyBndrsX emptyZonkEnv tvs ; pats' <- zonkTcTypeToTypes ze pats ; rhs_ty' <- zonkTcTypeToType ze rhs_ty - ; traceTc "tcTyFamInstEqn" (ppr fam_tc_name <+> pprTvBndrs tvs') + ; traceTc "tcTyFamInstEqn" (ppr fam_tc_name <+> pprTyVars tvs') -- don't print out the pats here, as they might be zonked inside the knot ; return (mkCoAxBranch tvs' [] pats' rhs_ty' (map (const Nominal) tvs') @@ -2236,7 +2236,7 @@ checkValidTyConTyVars tc = text "NB: Implicitly declared kind variables are put first." | otherwise = empty - ; checkValidTelescope (pprTvBndrs vis_tvs) stripped_tvs extra + ; checkValidTelescope (pprTyVars vis_tvs) stripped_tvs extra `and_if_that_doesn't_error` -- This triggers on test case dependent/should_fail/InferDependency -- It reports errors around Note [Dependent LHsQTyVars] in TcHsType diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index b316fe289f..6cc40a5d67 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -1790,7 +1790,7 @@ checkZonkValidTelescope hs_tvs orig_tvs extra addErr $ vcat [ hang (text "These kind and type variables:" <+> hs_tvs $$ text "are out of dependency order. Perhaps try this ordering:") - 2 (sep (map pprTvBndr sorted_tidied_tvs)) + 2 (sep (map pprTyVar sorted_tidied_tvs)) , extra ] ; return orig_tvs } diff --git a/compiler/types/Coercion.hs-boot b/compiler/types/Coercion.hs-boot index acd6aaf918..807d855772 100644 --- a/compiler/types/Coercion.hs-boot +++ b/compiler/types/Coercion.hs-boot @@ -3,6 +3,7 @@ module Coercion where import {-# SOURCE #-} TyCoRep import {-# SOURCE #-} TyCon +import BasicTypes ( LeftOrRight ) import CoAxiom import Var import Outputable diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index 62c186c71e..9979853f6b 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -32,7 +32,7 @@ module TyCoRep ( ArgFlag(..), -- * Coercions - Coercion(..), LeftOrRight(..), + Coercion(..), UnivCoProvenance(..), CoercionHole(..), CoercionN, CoercionR, CoercionP, KindCoercion, @@ -58,11 +58,12 @@ module TyCoRep ( -- * Pretty-printing pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs, pprSigmaType, - pprTheta, pprForAll, pprForAllImplicit, pprUserForAll, + pprTheta, pprForAll, pprUserForAll, + pprTyVar, pprTyVars, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprTyLit, TyPrec(..), maybeParen, pprTcAppCo, pprTcAppTy, - pprPrefixApp, pprArrowChain, ppr_type, + pprPrefixApp, pprArrowChain, pprDataCons, ppSuggestExplicitKinds, -- * Free variables @@ -127,36 +128,34 @@ module TyCoRep ( #include "HsVersions.h" -import {-# SOURCE #-} DataCon( dataConTyCon, dataConFullSig - , dataConUnivTyVarBinders, dataConExTyVarBinders - , DataCon, filterEqSpec ) +import {-# SOURCE #-} DataCon( dataConFullSig + , dataConUnivTyVarBinders, dataConExTyVarBinders + , DataCon, filterEqSpec ) import {-# SOURCE #-} Type( isPredTy, isCoercionTy, mkAppTy , tyCoVarsOfTypesWellScoped - , partitionInvisibles, coreView, typeKind - , eqType ) + , coreView, typeKind ) -- Transitively pulls in a LOT of stuff, better to break the loop import {-# SOURCE #-} Coercion import {-# SOURCE #-} ConLike ( ConLike(..), conLikeName ) -import {-# SOURCE #-} TysWiredIn ( ptrRepLiftedTy ) +import {-# SOURCE #-} ToIface -- friends: +import IfaceType import Var import VarEnv import VarSet import Name hiding ( varName ) -import BasicTypes import TyCon import Class import CoAxiom import FV -- others +import BasicTypes ( LeftOrRight(..), TyPrec(..), maybeParen, pickLR ) import PrelNames -import Binary import Outputable import DynFlags -import StaticFlags ( opt_PprStyle_Debug ) import FastString import Pair import UniqSupply @@ -833,25 +832,6 @@ type CoercionR = Coercion -- always representational type CoercionP = Coercion -- always phantom type KindCoercion = CoercionN -- always nominal --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.hs -data LeftOrRight = CLeft | CRight - deriving( Eq, Data.Data ) - -instance Binary LeftOrRight where - put_ bh CLeft = putByte bh 0 - put_ bh CRight = putByte bh 1 - - get bh = do { h <- getByte bh - ; case h of - 0 -> return CLeft - _ -> return CRight } - -pickLR :: LeftOrRight -> (a,a) -> a -pickLR CLeft (l,_) = l -pickLR CRight (_,r) = r - - {- Note [Refl invariant] ~~~~~~~~~~~~~~~~~~~~~ @@ -2291,7 +2271,7 @@ substTyVarBndrUnchecked = substTyVarBndrCallback substTyUnchecked substTyVarBndrCallback :: (TCvSubst -> Type -> Type) -- ^ the subst function -> TCvSubst -> TyVar -> (TCvSubst, TyVar) substTyVarBndrCallback subst_fn subst@(TCvSubst in_scope tenv cenv) old_var - = ASSERT2( _no_capture, pprTvBndr old_var $$ pprTvBndr new_var $$ ppr subst ) + = ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst ) ASSERT( isTyVar old_var ) (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var) where @@ -2401,106 +2381,14 @@ Maybe operator applications should bind a bit less tightly? Anyway, that's the current story, and it is used consistently for Type and HsType -} -data TyPrec -- See Note [Prededence in types] - = TopPrec -- No parens - | FunPrec -- Function args; no parens for tycon apps - | TyOpPrec -- Infix operator - | TyConPrec -- Tycon args; no parens for atomic - deriving( Eq, Ord ) - -maybeParen :: TyPrec -> TyPrec -> SDoc -> SDoc -maybeParen ctxt_prec inner_prec pretty - | ctxt_prec < inner_prec = pretty - | otherwise = parens pretty - ------------------ -{- -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 signficant 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 -PtrLiftedRep. This is done in a pass right before pretty-printing -(defaultRuntimeRepVars, controlled by -fprint-explicit-runtime-reps) --} - --- | Default 'RuntimeRep' variables to 'LiftedPtr'. e.g. --- --- @ --- ($) :: forall (r :: GHC.Types.RuntimeRep) a (b :: TYPE r). --- (a -> b) -> a -> b --- @ --- --- turns in to, --- --- @ ($) :: forall a (b :: *). (a -> b) -> a -> b @ --- --- We do this to prevent RuntimeRep variables from incurring a significant --- syntactic overhead in otherwise simple type signatures (e.g. ($)). See --- Note [Defaulting RuntimeRep variables] and #11549 for further discussion. --- -defaultRuntimeRepVars :: Type -> Type -defaultRuntimeRepVars = defaultRuntimeRepVars' emptyVarSet - -defaultRuntimeRepVars' :: TyVarSet -- ^ the binders which we should default - -> Type -> Type --- TODO: Eventually we should just eliminate the Type pretty-printer --- entirely and simply use IfaceType; this task is tracked as #11660. -defaultRuntimeRepVars' subs (ForAllTy (TvBndr var vis) ty) - | isRuntimeRepVar var = - let subs' = extendVarSet subs var - in defaultRuntimeRepVars' subs' ty - | otherwise = - let var' = var { varType = defaultRuntimeRepVars' subs (varType var) } - in ForAllTy (TvBndr var' vis) (defaultRuntimeRepVars' subs ty) - -defaultRuntimeRepVars' subs (FunTy kind ty) = - FunTy (defaultRuntimeRepVars' subs kind) - (defaultRuntimeRepVars' subs ty) - -defaultRuntimeRepVars' subs (TyVarTy var) - | var `elemVarSet` subs = ptrRepLiftedTy - -defaultRuntimeRepVars' subs (TyConApp tc args) = - TyConApp tc $ map (defaultRuntimeRepVars' subs) args - -defaultRuntimeRepVars' subs (AppTy x y) = - defaultRuntimeRepVars' subs x `AppTy` defaultRuntimeRepVars' subs y - -defaultRuntimeRepVars' subs (CastTy ty co) = - CastTy (defaultRuntimeRepVars' subs ty) co - -defaultRuntimeRepVars' _ other = other - -eliminateRuntimeRep :: (Type -> SDoc) -> Type -> SDoc -eliminateRuntimeRep f ty = sdocWithDynFlags $ \dflags -> - if gopt Opt_PrintExplicitRuntimeReps dflags - then f ty - else f (defaultRuntimeRepVars ty) - pprType, pprParendType :: Type -> SDoc -pprType ty = eliminateRuntimeRep (ppr_type TopPrec) ty -pprParendType ty = eliminateRuntimeRep (ppr_type TyConPrec) ty +pprType = pprIfaceType . toIfaceType +pprParendType = pprParendIfaceType . toIfaceType pprTyLit :: TyLit -> SDoc -pprTyLit = ppr_tylit TopPrec +pprTyLit = pprIfaceTyLit . toIfaceTyLit pprKind, pprParendKind :: Kind -> SDoc pprKind = pprType @@ -2512,38 +2400,10 @@ pprClassPred clas tys = pprTypeApp (classTyCon clas) tys ------------ pprTheta :: ThetaType -> SDoc -pprTheta [pred] = ppr_type TopPrec pred -- I'm in two minds about this -pprTheta theta = parens (sep (punctuate comma (map (ppr_type TopPrec) theta))) +pprTheta = pprIfaceContext . map toIfaceType pprThetaArrowTy :: ThetaType -> SDoc -pprThetaArrowTy [] = empty -pprThetaArrowTy [pred] = ppr_type TyOpPrec pred <+> darrow - -- TyOpPrec: Num a => a -> a does not need parens - -- bug (a :~: b) => a -> b currently does - -- Trac # 9658 -pprThetaArrowTy preds = parens (fsep (punctuate comma (map (ppr_type TopPrec) preds))) - <+> darrow - -- Notice 'fsep' here rather that 'sep', so that - -- type contexts don't get displayed in 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 get - -- - -- 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) +pprThetaArrowTy = pprIfaceContextArr . map toIfaceType ------------------ instance Outputable Type where @@ -2553,182 +2413,28 @@ instance Outputable TyLit where ppr = pprTyLit ------------------ - -- OK, here's the main printer - -ppr_type :: TyPrec -> Type -> SDoc -ppr_type _ (TyVarTy tv) = ppr_tvar tv - -ppr_type p (TyConApp tc tys) = pprTyTcApp p tc tys -ppr_type p (LitTy l) = ppr_tylit p l -ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty -ppr_type p ty@(FunTy {}) = ppr_forall_type p ty - -ppr_type p (AppTy t1 t2) - = if_print_coercions - ppr_app_ty - (case split_app_tys t1 [t2] of - (CastTy head _, args) -> ppr_type p (mk_app_tys head args) - _ -> ppr_app_ty) - where - ppr_app_ty = maybeParen p TyConPrec $ - ppr_type FunPrec t1 <+> ppr_type TyConPrec t2 - - split_app_tys (AppTy ty1 ty2) args = split_app_tys ty1 (ty2:args) - split_app_tys head args = (head, args) - - mk_app_tys (TyConApp tc tys1) tys2 = TyConApp tc (tys1 ++ tys2) - mk_app_tys ty1 tys2 = foldl AppTy ty1 tys2 - -ppr_type p (CastTy ty co) - = if_print_coercions - (parens (ppr_type TopPrec ty <+> text "|>" <+> ppr co)) - (ppr_type p ty) - -ppr_type _ (CoercionTy co) - = if_print_coercions - (parens (ppr co)) - (text "<>") - -ppr_forall_type :: TyPrec -> Type -> SDoc --- Used for types starting with ForAllTy or FunTy -ppr_forall_type p ty - = maybeParen p FunPrec $ - sdocWithDynFlags $ \dflags -> - ppr_sigma_type dflags True ty - -- True <=> we always print the foralls on *nested* quantifiers - -- Opt_PrintExplicitForalls only affects top-level quantifiers - -ppr_tvar :: TyVar -> SDoc -ppr_tvar tv -- Note [Infix type variables] - = parenSymOcc (getOccName tv) (ppr tv) - -ppr_tylit :: TyPrec -> TyLit -> SDoc -ppr_tylit _ tl = - case tl of - NumTyLit n -> integer n - StrTyLit s -> text (show s) - -if_print_coercions :: SDoc -- if printing coercions - -> SDoc -- otherwise - -> SDoc -if_print_coercions yes no - = sdocWithDynFlags $ \dflags -> - getPprStyle $ \style -> - if gopt Opt_PrintExplicitCoercions dflags - || dumpStyle style || debugStyle style - then yes - else no - -------------------- -ppr_sigma_type :: DynFlags - -> Bool -- ^ True <=> Show the foralls unconditionally - -> Type -> SDoc --- Used for types starting with ForAllTy or FunTy --- Suppose we have (forall a. Show a => forall b. a -> b). When we're not --- printing foralls, we want to drop both the (forall a) and the (forall b). --- This logic does so. -ppr_sigma_type dflags False orig_ty - | not (gopt Opt_PrintExplicitForalls dflags) - , all (isEmptyVarSet . tyCoVarsOfType . tyVarKind) tv_bndrs - -- See Note [When to print foralls] - = sep [ pprThetaArrowTy theta - , pprArrowChain TopPrec (ppr_fun_tail tau) ] - where - (tv_bndrs, theta, tau) = split [] [] orig_ty - - split :: [TyVar] -> [PredType] -> Type - -> ([TyVar], [PredType], Type) - split bndr_acc theta_acc (ForAllTy (TvBndr tv vis) ty) - | isInvisibleArgFlag vis = split (tv : bndr_acc) theta_acc ty - split bndr_acc theta_acc (FunTy ty1 ty2) - | isPredTy ty1 = split bndr_acc (ty1 : theta_acc) ty2 - split bndr_acc theta_acc ty = (reverse bndr_acc, reverse theta_acc, ty) - -ppr_sigma_type _ _ ty - = sep [ pprForAll bndrs - , pprThetaArrowTy ctxt - , pprArrowChain TopPrec (ppr_fun_tail tau) ] - where - (bndrs, rho) = split1 [] ty - (ctxt, tau) = split2 [] rho - - split1 bndrs (ForAllTy bndr ty) = split1 (bndr:bndrs) ty - split1 bndrs ty = (reverse bndrs, ty) - - split2 ps (FunTy ty1 ty2) | isPredTy ty1 = split2 (ty1:ps) ty2 - split2 ps ty = (reverse ps, ty) - - -- We don't want to lose synonyms, so we mustn't use splitFunTys here. -ppr_fun_tail :: Type -> [SDoc] -ppr_fun_tail (FunTy ty1 ty2) - | not (isPredTy ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2 -ppr_fun_tail other_ty = [ppr_type TopPrec other_ty] pprSigmaType :: Type -> SDoc --- Prints a top-level type for the user; in particular --- top-level foralls are omitted unless you use -fprint-explicit-foralls -pprSigmaType ty = sdocWithDynFlags $ \dflags -> - eliminateRuntimeRep (ppr_sigma_type dflags False) ty - -pprUserForAll :: [TyVarBinder] -> SDoc --- Print a user-level forall; see Note [When to print foralls] -pprUserForAll bndrs - = sdocWithDynFlags $ \dflags -> - ppWhen (any bndr_has_kind_var bndrs || gopt Opt_PrintExplicitForalls dflags) $ - pprForAll bndrs - where - bndr_has_kind_var bndr - = not (isEmptyVarSet (tyCoVarsOfType (binderKind bndr))) - -pprForAllImplicit :: [TyVar] -> SDoc -pprForAllImplicit tvs = pprForAll [ TvBndr tv Specified | tv <- tvs ] +pprSigmaType = pprIfaceSigmaType . toIfaceType --- | Render the "forall ... ." or "forall ... ->" bit of a type. --- Do not pass in anonymous binders! pprForAll :: [TyVarBinder] -> SDoc -pprForAll [] = empty -pprForAll bndrs@(TvBndr _ vis : _) - = add_separator (forAllLit <+> doc) <+> pprForAll bndrs' - where - (bndrs', doc) = ppr_tv_bndrs bndrs vis +pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs) - add_separator stuff = case vis of - Required -> stuff <+> arrow - _inv -> stuff <> dot +-- | Print a user-level forall; see Note [When to print foralls] +pprUserForAll :: [TyVarBinder] -> SDoc +pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr -pprTvBndrs :: [TyVar] -> SDoc +pprTvBndrs :: [TyVarBinder] -> SDoc pprTvBndrs tvs = sep (map pprTvBndr tvs) --- | Render the ... in @(forall ... .)@ or @(forall ... ->)@. --- Returns both the list of not-yet-rendered binders and the doc. -ppr_tv_bndrs :: [TyVarBinder] - -> ArgFlag -- ^ visibility of the first binder in the list - -> ([TyVarBinder], SDoc) -ppr_tv_bndrs all_bndrs@(TvBndr tv vis : bndrs) vis1 - | vis `sameVis` vis1 = let (bndrs', doc) = ppr_tv_bndrs bndrs vis1 - pp_tv = sdocWithDynFlags $ \dflags -> - if Inferred == vis && - gopt Opt_PrintExplicitForalls dflags - then braces (pprTvBndrNoParens tv) - else pprTvBndr tv - in - (bndrs', pp_tv <+> doc) - | otherwise = (all_bndrs, empty) -ppr_tv_bndrs [] _ = ([], empty) - -pprTvBndr :: TyVar -> SDoc -pprTvBndr tv - | isLiftedTypeKind kind = ppr_tvar tv - | otherwise = parens (ppr_tvar tv <+> dcolon <+> pprKind kind) - where - kind = tyVarKind tv - -pprTvBndrNoParens :: TyVar -> SDoc -pprTvBndrNoParens tv - | isLiftedTypeKind kind = ppr_tvar tv - | otherwise = ppr_tvar tv <+> dcolon <+> pprKind kind - where - kind = tyVarKind tv +pprTvBndr :: TyVarBinder -> SDoc +pprTvBndr = pprIfaceTvBndr True . toIfaceTvBndr . binderVar + +pprTyVars :: [TyVar] -> SDoc +pprTyVars tvs = sep (map pprTyVar tvs) + +pprTyVar :: TyVar -> SDoc +pprTyVar = pprIfaceTvBndr True . toIfaceTvBndr instance Outputable TyBinder where ppr (Anon ty) = text "[anon]" <+> ppr ty @@ -2739,9 +2445,6 @@ instance Outputable TyBinder where ----------------- instance Outputable Coercion where -- defined here to avoid orphans ppr = pprCo -instance Outputable LeftOrRight where - ppr CLeft = text "Left" - ppr CRight = text "Right" {- Note [When to print foralls] @@ -2799,249 +2502,23 @@ pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc] pprTypeApp :: TyCon -> [Type] -> SDoc -pprTypeApp tc tys = pprTyTcApp TopPrec tc tys - -- We have to use ppr on the TyCon (not its name) - -- so that we get promotion quotes in the right place - -pprTyTcApp :: TyPrec -> TyCon -> [Type] -> SDoc --- Used for types only; so that we can make a --- special case for type-level lists -pprTyTcApp p tc tys - | tc `hasKey` ipClassKey - , [LitTy (StrTyLit n),ty] <- tys - = maybeParen p FunPrec $ - char '?' <> ftext n <> text "::" <> ppr_type TopPrec ty - - | tc `hasKey` consDataConKey - , [_kind,ty1,ty2] <- tys - = sdocWithDynFlags $ \dflags -> - if gopt Opt_PrintExplicitKinds dflags then ppr_deflt - else pprTyList p ty1 ty2 - - | not opt_PprStyle_Debug - , tc `hasKey` errorMessageTypeErrorFamKey - = text "(TypeError ...)" -- Suppress detail unles you _really_ want to see - - | tc `hasKey` tYPETyConKey - , [TyConApp ptr_rep []] <- tys - , ptr_rep `hasKey` ptrRepLiftedDataConKey - = unicodeSyntax (char '★') (char '*') - - | tc `hasKey` tYPETyConKey - , [TyConApp ptr_rep []] <- tys - , ptr_rep `hasKey` ptrRepUnliftedDataConKey - = char '#' +pprTypeApp = pprTcAppTy TopPrec - | otherwise - = ppr_deflt - where - ppr_deflt = pprTcAppTy p ppr_type tc tys - -pprTcAppTy :: TyPrec -> (TyPrec -> Type -> SDoc) -> TyCon -> [Type] -> SDoc -pprTcAppTy p pp tc tys - = getPprStyle $ \style -> pprTcApp style id p pp tc tys +pprTcAppTy :: TyPrec -> TyCon -> [Type] -> SDoc +pprTcAppTy p tc tys + -- TODO: toIfaceTcArgs seems rather wasteful here + = pprIfaceTypeApp p (toIfaceTyCon tc) (toIfaceTcArgs tc tys) pprTcAppCo :: TyPrec -> (TyPrec -> Coercion -> SDoc) -> TyCon -> [Coercion] -> SDoc -pprTcAppCo p pp tc cos - = getPprStyle $ \style -> - pprTcApp style (pFst . coercionKind) p pp tc cos - -pprTcApp :: PprStyle - -> (a -> Type) -> TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> SDoc --- Used for both types and coercions, hence polymorphism -pprTcApp _ _ _ pp tc [ty] - | tc `hasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty) - | tc `hasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) - -pprTcApp style to_type p pp tc tys - | not (debugStyle style) - , Just sort <- tyConTuple_maybe tc - , let arity = tyConArity tc - , arity == length tys - , let num_to_drop = case sort of UnboxedTuple -> arity `div` 2 - _ -> 0 - = pprTupleApp p pp tc sort (drop num_to_drop tys) - - | not (debugStyle style) - , Just dc <- isPromotedDataCon_maybe tc - , let dc_tc = dataConTyCon dc - , Just tup_sort <- tyConTuple_maybe dc_tc - , let arity = tyConArity dc_tc -- E.g. 3 for (,,) k1 k2 k3 t1 t2 t3 - ty_args = drop arity tys -- Drop the kind args - , ty_args `lengthIs` arity -- Result is saturated - = pprPromotionQuote tc <> - (tupleParens tup_sort $ pprWithCommas (pp TopPrec) ty_args) - - | not (debugStyle style) - , isUnboxedSumTyCon tc - , let arity = tyConArity tc - ty_args = drop (arity `div` 2) tys -- Drop the kind args - , tys `lengthIs` arity -- Not a partial application - = pprSumApp pp tc ty_args - - | otherwise - = sdocWithDynFlags $ \dflags -> - pprTcApp_help to_type p pp tc tys dflags style - -pprTupleApp :: TyPrec -> (TyPrec -> a -> SDoc) - -> TyCon -> TupleSort -> [a] -> SDoc --- Print a saturated tuple -pprTupleApp p pp tc sort tys - | null tys - , ConstraintTuple <- sort - = if opt_PprStyle_Debug then text "(%%)" - else maybeParen p FunPrec $ - text "() :: Constraint" - | otherwise - = pprPromotionQuote tc <> - tupleParens sort (pprWithCommas (pp TopPrec) tys) - -pprSumApp :: (TyPrec -> a -> SDoc) -> TyCon -> [a] -> SDoc -pprSumApp pp tc tys - = pprPromotionQuote tc <> - sumParens (pprWithBars (pp TopPrec) tys) - -pprTcApp_help :: (a -> Type) -> TyPrec -> (TyPrec -> a -> SDoc) - -> TyCon -> [a] -> DynFlags -> PprStyle -> SDoc --- This one has accss to the DynFlags -pprTcApp_help to_type p pp tc tys dflags style - | not (isSymOcc (nameOccName tc_name)) -- Print prefix - = pprPrefixApp p pp_tc (map (pp TyConPrec) tys_wo_kinds) - - | Just args <- mb_saturated_equality - = print_equality args - - -- So we have an operator symbol of some kind - - | [ty1,ty2] <- tys_wo_kinds -- Infix, two arguments; - -- we know nothing of precedence though - = pprInfixApp p pp pp_tc ty1 ty2 - - | tc_name `hasKey` starKindTyConKey - || tc_name `hasKey` unicodeStarKindTyConKey - || tc_name `hasKey` unliftedTypeKindTyConKey - = pp_tc -- Do not wrap *, # in parens - - | otherwise -- Unsaturated operator - = pprPrefixApp p (parens (pp_tc)) (map (pp TyConPrec) tys_wo_kinds) - where - tc_name = tyConName tc - pp_tc = ppr tc - tys_wo_kinds = suppressInvisibles to_type dflags tc tys - - -- See Note [Printing equality constraints] - mb_saturated_equality - | hetero_eq_tc - , [k1, k2, t1, t2] <- tys - = Just (k1, k2, t1, t2) - | homo_eq_tc - , [k, t1, t2] <- tys -- we must have (~) - = Just (k, k, t1, t2) - | otherwise - = Nothing - - -- See Note [Printing equality constraints] - homo_eq_tc = tc `hasKey` eqTyConKey -- ~ - hetero_eq_tc = tc `hasKey` eqPrimTyConKey -- ~# - || tc `hasKey` eqReprPrimTyConKey -- ~R# - || tc `hasKey` heqTyConKey -- ~~ - - -- See Note [Printing equality constraints] - print_equality (ki1, ki2, ty1, ty2) - | print_eqs - = ppr_infix_eq pp_tc - - | hetero_eq_tc - , print_kinds || not (to_type ki1 `eqType` to_type ki2) - = ppr_infix_eq $ if tc `hasKey` eqPrimTyConKey - then text "~~" - else pp_tc - - | otherwise - = if tc `hasKey` eqReprPrimTyConKey - then text "Coercible" <+> (sep [ pp TyConPrec ty1 - , pp TyConPrec ty2 ]) - else sep [pp TyOpPrec ty1, text "~", pp TyOpPrec ty2] - - where - ppr_infix_eq eq_op - = sep [ parens (pp TyOpPrec ty1 <+> dcolon <+> pp TyOpPrec ki1) - , eq_op - , parens (pp TyOpPrec ty2 <+> dcolon <+> pp TyOpPrec ki2)] - - print_kinds = gopt Opt_PrintExplicitKinds dflags - print_eqs = gopt Opt_PrintEqualityRelations dflags || - dumpStyle style || - debugStyle style - -{- Note [Printing equality constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC has a lot of differnent equalities: - ~ Boxed homogeneous Nominal - ~~ Boxed heterogeneous Nominal - ~# Unboxed heterogeneous Nominal - ~R# Unboxed heterogeneous Representational - -This is cofusing to the user, so when priting we usse this -strategy: - -If -fprint-equality-relations or -dppr-debug or we are in - "dump style", then print the relation as-is, which - distinguishes the various different equalities listed - above - -If ...something about heterogeneous equalities - -Otherwise print 'Coercible' for (~R#), and "~" for the others. - -This is all a bit ad-hoc, trying to print out the best representation -of equalities. If you see a better design, go for it. --} +pprTcAppCo p _pp tc cos + = pprIfaceCoTcApp p (toIfaceTyCon tc) (map toIfaceCoercion cos) ------------------ --- | Given a 'TyCon',and the args to which it is applied, --- suppress the args that are implicit -suppressInvisibles :: (a -> Type) -> DynFlags -> TyCon -> [a] -> [a] -suppressInvisibles to_type dflags tc xs - | gopt Opt_PrintExplicitKinds dflags = xs - | otherwise = snd $ partitionInvisibles tc to_type xs - ----------------- -pprTyList :: TyPrec -> Type -> Type -> SDoc --- Given a type-level list (t1 ': t2), see if we can print --- it in list notation [t1, ...]. -pprTyList p ty1 ty2 - = case gather ty2 of - (arg_tys, Nothing) -> char '\'' <> brackets (fsep (punctuate comma - (map (ppr_type TopPrec) (ty1:arg_tys)))) - (arg_tys, Just tl) -> maybeParen p FunPrec $ - hang (ppr_type FunPrec ty1) - 2 (fsep [ colon <+> ppr_type FunPrec ty | ty <- arg_tys ++ [tl]]) - where - gather :: Type -> ([Type], Maybe Type) - -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn] - -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl - gather (TyConApp tc tys) - | tc `hasKey` consDataConKey - , [_kind, ty1,ty2] <- tys - , (args, tl) <- gather ty2 - = (ty1:args, tl) - | tc `hasKey` nilDataConKey - = ([], Nothing) - gather ty = ([], Just ty) - ----------------- -pprInfixApp :: TyPrec -> (TyPrec -> a -> SDoc) -> SDoc -> a -> a -> SDoc -pprInfixApp p pp pp_tc ty1 ty2 - = maybeParen p TyOpPrec $ - sep [pp TyOpPrec ty1, pprInfixVar True pp_tc <+> pp TyOpPrec ty2] pprPrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc -pprPrefixApp p pp_fun pp_tys - | null pp_tys = pp_fun - | otherwise = maybeParen p TyConPrec $ - hang pp_fun 2 (sep pp_tys) +pprPrefixApp = pprIfacePrefixApp + ---------------- pprArrowChain :: TyPrec -> [SDoc] -> SDoc -- pprArrowChain p [a,b,c] generates a -> b -> c diff --git a/compiler/types/TyCoRep.hs-boot b/compiler/types/TyCoRep.hs-boot index df2dfd59a4..8dcbd10744 100644 --- a/compiler/types/TyCoRep.hs-boot +++ b/compiler/types/TyCoRep.hs-boot @@ -6,9 +6,10 @@ import Data.Data ( Data ) data Type data TyThing data Coercion -data LeftOrRight data UnivCoProvenance data TCvSubst +data TyLit +data TyBinder type PredType = Type type Kind = Type diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index 40e8562b35..054eb2bfb1 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -1436,7 +1436,7 @@ mkClassTyCon name binders roles rhs clas tc_rep_name mkTupleTyCon :: Name -> [TyConBinder] -> Kind -- ^ Result kind of the 'TyCon' - -> Arity -- ^ Arity of the tuple + -> Arity -- ^ Arity of the tuple 'TyCon' -> DataCon -> TupleSort -- ^ Whether the tuple is boxed or unboxed -> AlgTyConFlav diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index f615757b2b..86cb5a8cf8 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -175,12 +175,12 @@ module Type ( -- * Pretty-printing pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprShortTyThing, - pprTvBndr, pprTvBndrs, pprForAll, pprForAllImplicit, pprUserForAll, + pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll, pprSigmaType, ppSuggestExplicitKinds, pprTheta, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprSourceTyCon, TyPrec(..), maybeParen, - pprTyVar, pprTcAppTy, pprPrefixApp, pprArrowChain, + pprTyVar, pprTyVars, pprTcAppTy, pprPrefixApp, pprArrowChain, -- * Tidying type related things up for printing tidyType, tidyTypes, @@ -2178,10 +2178,6 @@ typeLiteralKind l = NumTyLit _ -> typeNatKind StrTyLit _ -> typeSymbolKind --- | Print a tyvar with its kind -pprTyVar :: TyVar -> SDoc -pprTyVar tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) - {- %************************************************************************ %* * diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 61e1ee8cd1..26a4d19366 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -750,6 +750,14 @@ instance Binary FastString where UserData { ud_get_fs = get_fs } -> get_fs bh -- Here to avoid loop +instance Binary LeftOrRight where + put_ bh CLeft = putByte bh 0 + put_ bh CRight = putByte bh 1 + + get bh = do { h <- getByte bh + ; case h of + 0 -> return CLeft + _ -> return CRight } instance Binary Fingerprint where put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr index 43ffb06033..ff1047db84 100644 --- a/testsuite/tests/deSugar/should_compile/T2431.stderr +++ b/testsuite/tests/deSugar/should_compile/T2431.stderr @@ -17,7 +17,7 @@ T2431.$WRefl = T2431.Refl @ a @ a @~ (<a>_N :: (a :: *) GHC.Prim.~# (a :: *)) -- RHS size: {terms: 4, types: 8, coercions: 0} -absurd :: forall a. Int :~: Bool -> a +absurd :: forall a. (Int :~: Bool) -> a [GblId, Arity=1, Caf=NoCafRefs, Str=<L,U>x] absurd = \ (@ a) (x :: Int :~: Bool) -> case x of { } diff --git a/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr b/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr index 963dcbb6a3..88539858cf 100644 --- a/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr +++ b/testsuite/tests/dependent/should_fail/TypeSkolEscape.stderr @@ -2,6 +2,6 @@ TypeSkolEscape.hs:8:1: error: • Quantified type's kind mentions quantified type variable (skolem escape) - type: forall a1. a1 + type: forall (a1 :: TYPE v1). a1 of kind: TYPE v • In the type synonym declaration for ‘Bad’ diff --git a/testsuite/tests/ghci/scripts/T11252.stdout b/testsuite/tests/ghci/scripts/T11252.stdout index eddba4530e..f6d45ddf32 100644 --- a/testsuite/tests/ghci/scripts/T11252.stdout +++ b/testsuite/tests/ghci/scripts/T11252.stdout @@ -1 +1 @@ -Proxy1 :: forall k -> k -> * +Proxy1 :: k -> * diff --git a/testsuite/tests/ghci/scripts/T2766.stdout b/testsuite/tests/ghci/scripts/T2766.stdout index 5bcbd9e75e..f8ee42ff6a 100644 --- a/testsuite/tests/ghci/scripts/T2766.stdout +++ b/testsuite/tests/ghci/scripts/T2766.stdout @@ -1,3 +1,3 @@ first :: Arrow to => b `to` c -> (b, d) `to` (c, d) :: Arrow to => to b c -> to (b, d) (c, d) -first :: b~>c -> (b, d)~>(c, d) :: b ~> c -> (b, d) ~> (c, d) +first :: b~>c -> (b, d)~>(c, d) :: (b ~> c) -> (b, d) ~> (c, d) diff --git a/testsuite/tests/ghci/scripts/ghci059.stdout b/testsuite/tests/ghci/scripts/ghci059.stdout index 3cb103c9f5..9f4e65b344 100644 --- a/testsuite/tests/ghci/scripts/ghci059.stdout +++ b/testsuite/tests/ghci/scripts/ghci059.stdout @@ -1,4 +1,4 @@ type role Coercible representational representational -class a ~R# b => Coercible (a :: k0) (b :: k0) +class Coercible a b => Coercible (a :: k0) (b :: k0) -- Defined in ‘GHC.Types’ coerce :: Coercible a b => a -> b -- Defined in ‘GHC.Prim’ diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr index df20e67f3a..5369daa5cd 100644 --- a/testsuite/tests/roles/should_compile/T8958.stderr +++ b/testsuite/tests/roles/should_compile/T8958.stderr @@ -65,8 +65,7 @@ AbsBinds [a] [] Exported types: T8958.$fRepresentationala [InlPrag=[ALWAYS] CONLIKE] :: forall a. Representational a [LclIdX[DFunId], - Unf=DFun: \ (@ a[ssk:2]) -> - T8958.C:Representational TYPE: a[ssk:2]] + Unf=DFun: \ (@ a) -> T8958.C:Representational TYPE: a] Binds: $dRepresentational = T8958.C:Representational @ a Evidence: [EvBinds{}]} AbsBinds [a] [] @@ -74,8 +73,7 @@ AbsBinds [a] [] wrap: <>] Exported types: T8958.$fNominala [InlPrag=[ALWAYS] CONLIKE] :: forall a. Nominal a - [LclIdX[DFunId], - Unf=DFun: \ (@ a[ssk:2]) -> T8958.C:Nominal TYPE: a[ssk:2]] + [LclIdX[DFunId], Unf=DFun: \ (@ a) -> T8958.C:Nominal TYPE: a] Binds: $dNominal = T8958.C:Nominal @ a Evidence: [EvBinds{}]} diff --git a/testsuite/tests/typecheck/should_compile/T10632.stderr b/testsuite/tests/typecheck/should_compile/T10632.stderr index 1733f0ae7a..0796146b17 100644 --- a/testsuite/tests/typecheck/should_compile/T10632.stderr +++ b/testsuite/tests/typecheck/should_compile/T10632.stderr @@ -1,5 +1,5 @@ T10632.hs:4:1: warning: [-Wredundant-constraints] - • Redundant constraint: ?file1::String + • Redundant constraint: (?file1::String) • In the type signature for: f :: (?file1::String) => IO () diff --git a/testsuite/tests/typecheck/should_fail/ClassOperator.stderr b/testsuite/tests/typecheck/should_fail/ClassOperator.stderr index 29ac2d240d..30791286c2 100644 --- a/testsuite/tests/typecheck/should_fail/ClassOperator.stderr +++ b/testsuite/tests/typecheck/should_fail/ClassOperator.stderr @@ -1,7 +1,7 @@ ClassOperator.hs:12:3: error: • Could not deduce (a ><> b0) - from the context: a ><> b + from the context: (a ><> b) bound by the type signature for: (**>) :: (a ><> b) => a -> a -> () at ClassOperator.hs:12:3-44 @@ -14,7 +14,7 @@ ClassOperator.hs:12:3: error: ClassOperator.hs:12:3: error: • Could not deduce (a ><> b0) - from the context: a ><> b + from the context: (a ><> b) bound by the type signature for: (**<) :: (a ><> b) => a -> a -> () at ClassOperator.hs:12:3-44 @@ -27,7 +27,7 @@ ClassOperator.hs:12:3: error: ClassOperator.hs:12:3: error: • Could not deduce (a ><> b0) - from the context: a ><> b + from the context: (a ><> b) bound by the type signature for: (>**) :: (a ><> b) => a -> a -> () at ClassOperator.hs:12:3-44 @@ -40,7 +40,7 @@ ClassOperator.hs:12:3: error: ClassOperator.hs:12:3: error: • Could not deduce (a ><> b0) - from the context: a ><> b + from the context: (a ><> b) bound by the type signature for: (<**) :: (a ><> b) => a -> a -> () at ClassOperator.hs:12:3-44 diff --git a/testsuite/tests/typecheck/should_fail/IPFail.stderr b/testsuite/tests/typecheck/should_fail/IPFail.stderr index 72c11b0c0d..0ba5bce32a 100644 --- a/testsuite/tests/typecheck/should_fail/IPFail.stderr +++ b/testsuite/tests/typecheck/should_fail/IPFail.stderr @@ -1,7 +1,7 @@ IPFail.hs:6:18: error: • Could not deduce (Num Bool) arising from the literal ‘5’ - from the context: ?x::Int + from the context: (?x::Int) bound by the type signature for: f0 :: (?x::Int) => () -> Bool at IPFail.hs:5:1-31 diff --git a/testsuite/tests/typecheck/should_fail/T7019a.stderr b/testsuite/tests/typecheck/should_fail/T7019a.stderr index a50fbcf240..9772b85e58 100644 --- a/testsuite/tests/typecheck/should_fail/T7019a.stderr +++ b/testsuite/tests/typecheck/should_fail/T7019a.stderr @@ -2,6 +2,6 @@ T7019a.hs:11:1: error: • Illegal polymorphic type: forall b. Context (Associated a b) A constraint must be a monotype - • In the context: forall b. Context (Associated a b) + • In the context: (forall b. Context (Associated a b)) While checking the super-classes of class ‘Class’ In the class declaration for ‘Class’ diff --git a/testsuite/tests/typecheck/should_fail/T7525.stderr b/testsuite/tests/typecheck/should_fail/T7525.stderr index 4d6f8d3a90..99b9c2861d 100644 --- a/testsuite/tests/typecheck/should_fail/T7525.stderr +++ b/testsuite/tests/typecheck/should_fail/T7525.stderr @@ -1,9 +1,9 @@ -T7525.hs:5:30: - Could not deduce: ?b::Bool - arising from a use of implicit parameter ‘?b’ - from the context: ?a::Bool - bound by the implicit-parameter binding for ?a at T7525.hs:5:7-31 - In the second argument of ‘(&&)’, namely ‘?b’ - In the expression: ?a && ?b - In the expression: let ?a = True in ?a && ?b +T7525.hs:5:30: error: + • Could not deduce: (?b::Bool) + arising from a use of implicit parameter ‘?b’ + from the context: (?a::Bool) + bound by the implicit-parameter binding for ?a at T7525.hs:5:7-31 + • In the second argument of ‘(&&)’, namely ‘?b’ + In the expression: ?a && ?b + In the expression: let ?a = True in ?a && ?b diff --git a/testsuite/tests/typecheck/should_fail/T8912.stderr b/testsuite/tests/typecheck/should_fail/T8912.stderr index 4e4515e7a1..78fdd108dd 100644 --- a/testsuite/tests/typecheck/should_fail/T8912.stderr +++ b/testsuite/tests/typecheck/should_fail/T8912.stderr @@ -1,6 +1,6 @@ -T8912.hs:7:10: - Illegal implicit parameter ‘?imp::Int’ - In the context: ?imp::Int - While checking an instance declaration - In the instance declaration for ‘C [a]’ +T8912.hs:7:10: error: + • Illegal implicit parameter ‘?imp::Int’ + • In the context: (?imp::Int) + While checking an instance declaration + In the instance declaration for ‘C [a]’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail041.stderr b/testsuite/tests/typecheck/should_fail/tcfail041.stderr index fe116b5277..d2d3214d9e 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail041.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail041.stderr @@ -1,6 +1,6 @@ -tcfail041.hs:5:1: - Illegal implicit parameter ‘?imp::Int’ - In the context: ?imp::Int - While checking the super-classes of class ‘D’ - In the class declaration for ‘D’ +tcfail041.hs:5:1: error: + • Illegal implicit parameter ‘?imp::Int’ + • In the context: (?imp::Int) + While checking the super-classes of class ‘D’ + In the class declaration for ‘D’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail130.stderr b/testsuite/tests/typecheck/should_fail/tcfail130.stderr index 7640031cbd..51f77d14c6 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail130.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail130.stderr @@ -1,5 +1,6 @@ -tcfail130.hs:10:7: - Unbound implicit parameter ?x::Int arising from a use of ‘woggle’ - In the expression: woggle 3 - In an equation for ‘foo’: foo = woggle 3 +tcfail130.hs:10:7: error: + • Unbound implicit parameter (?x::Int) + arising from a use of ‘woggle’ + • In the expression: woggle 3 + In an equation for ‘foo’: foo = woggle 3 diff --git a/testsuite/tests/typecheck/should_fail/tcfail211.stderr b/testsuite/tests/typecheck/should_fail/tcfail211.stderr index 7a5053a092..a88cc35507 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail211.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail211.stderr @@ -1,12 +1,12 @@ tcfail211.hs:5:1: error: • Illegal implicit parameter ‘?imp::Int’ - • In the context: ?imp::Int + • In the context: (?imp::Int) While checking the super-classes of class ‘D’ In the class declaration for ‘D’ tcfail211.hs:8:10: error: • Illegal implicit parameter ‘?imp::Int’ - • In the context: ?imp::Int + • In the context: (?imp::Int) While checking an instance declaration In the instance declaration for ‘D Int’ diff --git a/testsuite/tests/typecheck/should_run/tcrun045.stderr b/testsuite/tests/typecheck/should_run/tcrun045.stderr index f6b1652e5b..19fca1096f 100644 --- a/testsuite/tests/typecheck/should_run/tcrun045.stderr +++ b/testsuite/tests/typecheck/should_run/tcrun045.stderr @@ -1,18 +1,18 @@ tcrun045.hs:11:10: error: • Illegal implicit parameter ‘?imp::Int’ - • In the context: ?imp::Int + • In the context: (?imp::Int) While checking an instance declaration In the instance declaration for ‘C Int’ tcrun045.hs:24:1: error: • Illegal implicit parameter ‘?imp::Int’ - • In the context: ?imp::Int + • In the context: (?imp::Int) While checking the super-classes of class ‘D’ In the class declaration for ‘D’ tcrun045.hs:27:10: error: • Illegal implicit parameter ‘?imp::Int’ - • In the context: ?imp::Int + • In the context: (?imp::Int) While checking an instance declaration In the instance declaration for ‘D Int’ |