X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTypeRep.lhs;h=33723120e5d3d4fd5e142697e98bfaa6b3c8dad4;hb=474b582b68ea9289f3da4355da816164138604b0;hp=c222bf4d4ddf12a865b953348574e44b5afb665c;hpb=b0842998a6bad0cae47f980f4ed9156701c8198b;p=ghc-hetmet.git diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index c222bf4..3372312 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -1,4 +1,5 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1998 % \section[TypeRep]{Type - friends' interface} @@ -14,14 +15,15 @@ module TypeRep ( funTyCon, -- Pretty-printing - pprType, pprParendType, pprTyThingCategory, - pprPred, pprTheta, pprThetaArrow, pprClassPred, + pprType, pprParendType, pprTypeApp, + pprTyThingCategory, + pprPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred, -- Kinds liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, isLiftedTypeKindCon, isLiftedTypeKind, - mkArrowKind, mkArrowKinds, + mkArrowKind, mkArrowKinds, isCoercionKind, -- Kind constructors... liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, @@ -43,24 +45,18 @@ module TypeRep ( #include "HsVersions.h" import {-# SOURCE #-} DataCon( DataCon, dataConName ) --- friends: -import Var ( Var, Id, TyVar, tyVarKind ) -import VarSet ( TyVarSet ) -import Name ( Name, NamedThing(..), BuiltInSyntax(..), mkWiredInName ) -import OccName ( mkOccNameFS, tcName, parenSymOcc ) -import BasicTypes ( IPName, tupleParens ) -import TyCon ( TyCon, mkFunTyCon, tyConArity, tupleTyConBoxity, isTupleTyCon, - isRecursiveTyCon, isNewTyCon, mkVoidPrimTyCon, - mkSuperKindTyCon ) -import Class ( Class ) +-- friends: +import Var +import VarSet +import Name +import OccName +import BasicTypes +import TyCon +import Class -- others -import PrelNames ( gHC_PRIM, funTyConKey, tySuperKindTyConKey, - coSuperKindTyConKey, liftedTypeKindTyConKey, - openTypeKindTyConKey, unliftedTypeKindTyConKey, - ubxTupleKindTyConKey, argTypeKindTyConKey, listTyConKey, - parrTyConKey, hasKey ) +import PrelNames import Outputable \end{code} @@ -237,7 +233,7 @@ Predicates are represented inside GHC by PredType: data PredType = ClassP Class [Type] -- Class predicate | IParam (IPName Name) Type -- Implicit parameter - | EqPred Type Type -- Equality predicate (ty1 :=: ty2) + | EqPred Type Type -- Equality predicate (ty1 ~ ty2) type ThetaType = [PredType] \end{code} @@ -256,7 +252,7 @@ represented by evidence (a dictionary, for example, of type (predRepTy p). Note [Equality predicates] ~~~~~~~~~~~~~~~~~~~~~~~~~~ - forall a b. (a :=: S b) => a -> b + forall a b. (a ~ S b) => a -> b could be represented by ForAllTy a (ForAllTy b (FunTy (PredTy (EqPred a (S b))) ...)) OR @@ -322,7 +318,7 @@ funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] lif -- You might think that (->) should have type (?? -> ? -> *), and you'd be right -- But if we do that we get kind errors when saying -- instance Control.Arrow (->) - -- because the expected kind is (*->*->*). The trouble is that the + -- becuase the expected kind is (*->*->*). The trouble is that the -- expected/actual stuff in the unifier does not go contra-variant, whereas -- the kind sub-typing does. Sigh. It really only matters if you use (->) in -- a prefix way, thus: (->) Int# Int#. And this is unusual. @@ -354,7 +350,6 @@ funTyConName = mkPrimTyConName FSLIT("(->)") funTyConKey funTyCon mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkOccNameFS tcName occ) key - Nothing -- No parent object (ATyCon tycon) BuiltInSyntax -- All of the super kinds and kinds are defined in Prim and use BuiltInSyntax, @@ -392,14 +387,21 @@ isCoSuperKind (TyConApp kc []) = kc `hasKey` coSuperKindTyConKey isCoSuperKind other = False ------------------- --- lastly we need a few functions on Kinds +-- Lastly we need a few functions on Kinds isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey +isLiftedTypeKind :: Kind -> Bool isLiftedTypeKind (TyConApp tc []) = isLiftedTypeKindCon tc isLiftedTypeKind other = False - +isCoercionKind :: Kind -> Bool +-- All coercions are of form (ty1 ~ ty2) +-- This function is here rather than in Coercion, +-- because it's used in a knot-tied way to enforce invariants in Var +isCoercionKind (NoteTy _ k) = isCoercionKind k +isCoercionKind (PredTy (EqPred {})) = True +isCoercionKind other = False \end{code} @@ -431,15 +433,19 @@ pprType, pprParendType :: Type -> SDoc pprType ty = ppr_type TopPrec ty pprParendType ty = ppr_type TyConPrec ty +pprTypeApp :: NamedThing a => a -> SDoc -> [Type] -> SDoc +-- The first arg is the tycon; it's used to arrange printing infix +-- if it looks like an operator +-- Second arg is the pretty-printed tycon +pprTypeApp tc pp_tc tys = ppr_type_app TopPrec (getName tc) pp_tc tys + ------------------ pprPred :: PredType -> SDoc pprPred (ClassP cls tys) = pprClassPred cls tys pprPred (IParam ip ty) = ppr ip <> dcolon <> pprType ty -pprPred (EqPred ty1 ty2) = sep [ppr ty1, nest 2 (ptext SLIT(":=:")), ppr ty2] - +pprPred (EqPred ty1 ty2) = sep [ppr ty1, nest 2 (ptext SLIT("~")), ppr ty2] pprClassPred :: Class -> [Type] -> SDoc -pprClassPred clas tys = parenSymOcc (getOccName clas) (ppr clas) - <+> sep (map pprParendType tys) +pprClassPred clas tys = ppr_type_app TopPrec (getName clas) (ppr clas) tys pprTheta :: ThetaType -> SDoc pprTheta theta = parens (sep (punctuate comma (map pprPred theta))) @@ -467,7 +473,7 @@ pprParendKind = pprParendType ppr_type :: Prec -> Type -> SDoc ppr_type p (TyVarTy tv) = ppr tv -ppr_type p (PredTy pred) = braces (ppr pred) +ppr_type p (PredTy pred) = ifPprDebug (ptext SLIT("")) <> (ppr pred) ppr_type p (NoteTy other ty2) = ppr_type p ty2 ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys @@ -519,11 +525,27 @@ ppr_tc_app p tc tys | isTupleTyCon tc && tyConArity tc == length tys = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys))) | otherwise - = maybeParen p TyConPrec $ - ppr_tc tc <+> sep (map (ppr_type TyConPrec) tys) + = ppr_type_app p (getName tc) (ppr_naked_tc tc) tys + +ppr_type_app :: Prec -> Name -> SDoc -> [Type] -> SDoc +ppr_type_app p tc pp_tc tys + | is_sym_occ -- Print infix if possible + , [ty1,ty2] <- tys -- We know nothing of precedence though + = maybeParen p FunPrec (sep [ppr_type FunPrec ty1, + pp_tc <+> ppr_type FunPrec ty2]) + | otherwise + = maybeParen p TyConPrec (hang paren_tc 2 (sep (map pprParendType tys))) + where + is_sym_occ = isSymOcc (getOccName tc) + paren_tc | is_sym_occ = parens pp_tc + | otherwise = pp_tc ppr_tc :: TyCon -> SDoc -ppr_tc tc = parenSymOcc (getOccName tc) (pp_nt_debug <> ppr tc) +ppr_tc tc = parenSymOcc (getOccName tc) (ppr_naked_tc tc) + +ppr_naked_tc :: TyCon -> SDoc -- No brackets for SymOcc +ppr_naked_tc tc + = pp_nt_debug <> ppr tc where pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc then ptext SLIT("")