X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FTypeRep.lhs;h=c694dc8b79ef74babcf2da6af4413543f00e1255;hp=7bb863a210e37841c77a8b7be7a6dac00985a439;hb=deda0c55629600e886f47a5e90bad67953df1ad8;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 7bb863a..c694dc8 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -1,9 +1,17 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1998 % \section[TypeRep]{Type - friends' interface} \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module TypeRep ( TyThing(..), Type(..), TyNote(..), -- Representation visible @@ -14,13 +22,30 @@ module TypeRep ( funTyCon, -- Pretty-printing - pprType, pprParendType, pprTyThingCategory, - pprPred, pprTheta, pprThetaArrow, pprClassPred, + pprType, pprParendType, pprTypeApp, + pprTyThing, pprTyThingCategory, + pprPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred, - -- Re-export fromKind + -- Kinds liftedTypeKind, unliftedTypeKind, openTypeKind, - isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, - mkArrowKind, mkArrowKinds, + argTypeKind, ubxTupleKind, + isLiftedTypeKindCon, isLiftedTypeKind, + mkArrowKind, mkArrowKinds, isCoercionKind, + + -- Kind constructors... + liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, + argTypeKindTyCon, ubxTupleKindTyCon, + + -- And their names + unliftedTypeKindTyConName, openTypeKindTyConName, + ubxTupleKindTyConName, argTypeKindTyConName, + liftedTypeKindTyConName, + + -- Super Kinds + tySuperKind, coSuperKind, + isTySuperKind, isCoSuperKind, + tySuperKindTyCon, coSuperKindTyCon, + pprKind, pprParendKind ) where @@ -29,17 +54,16 @@ module TypeRep ( import {-# SOURCE #-} DataCon( DataCon, dataConName ) -- friends: -import Kind -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 ) -import Class ( Class ) +import Var +import VarSet +import Name +import OccName +import BasicTypes +import TyCon +import Class -- others -import PrelNames ( gHC_PRIM, funTyConKey, listTyConKey, parrTyConKey, hasKey ) +import PrelNames import Outputable \end{code} @@ -170,18 +194,30 @@ data Type TyVar Type - | PredTy -- A high level source type - PredType -- ...can be expanded to a representation type... + | PredTy -- The type of evidence for a type predictate + PredType -- See Note [PredTy], and Note [Equality predicates] + -- NB: A PredTy (EqPred _ _) can appear only as the kind + -- of a coercion variable; never as the argument or result + -- of a FunTy (unlike ClassP, IParam) | NoteTy -- A type with a note attached TyNote Type -- The expanded version +type Kind = Type -- Invariant: a kind is always + -- FunTy k1 k2 + -- or TyConApp PrimTyCon [...] + -- or TyVar kv (during inference only) + -- or ForAll ... (for top-level coercions) + +type SuperKind = Type -- Invariant: a super kind is always + -- TyConApp SuperKindTyCon ... + data TyNote = FTVNote TyVarSet -- The free type variables of the noted expression \end{code} ------------------------------------- - Source types + Note [PredTy] A type of the form PredTy p @@ -204,6 +240,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) type ThetaType = [PredType] \end{code} @@ -220,6 +257,24 @@ The predicate really does turn into a real extra argument to the function. If the argument has type (PredTy p) then the predicate p is represented by evidence (a dictionary, for example, of type (predRepTy p). +Note [Equality predicates] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + forall a b. (a ~ S b) => a -> b +could be represented by + ForAllTy a (ForAllTy b (FunTy (PredTy (EqPred a (S b))) ...)) +OR + ForAllTy a (ForAllTy b (ForAllTy (c::PredTy (EqPred a (S b))) ...)) + +The latter is what we do. (Unlike for class and implicit parameter +constraints, which do use FunTy.) + +Reason: + * FunTy is always a *value* function + * ForAllTy is discarded at runtime + +We often need to make a "wildcard" (c::PredTy..). We always use the same +name (wildCoVarName), since it's not mentioned. + %************************************************************************ %* * @@ -237,8 +292,11 @@ data TyThing = AnId Id | ATyCon TyCon | AClass Class -instance Outputable TyThing where - ppr thing = pprTyThingCategory thing <+> quotes (ppr (getName thing)) +instance Outputable TyThing where + ppr = pprTyThing + +pprTyThing :: TyThing -> SDoc +pprTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing)) pprTyThingCategory :: TyThing -> SDoc pprTyThingCategory (ATyCon _) = ptext SLIT("Type constructor") @@ -256,13 +314,16 @@ instance NamedThing TyThing where -- Can't put this with the type %************************************************************************ %* * -\subsection{Wired-in type constructors + Wired-in type constructors %* * %************************************************************************ We define a few wired-in type constructors here to avoid module knots \begin{code} +-------------------------- +-- First the TyCons... + funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) -- You might think that (->) should have type (?? -> ? -> *), and you'd be right -- But if we do that we get kind errors when saying @@ -272,15 +333,89 @@ funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] lif -- the kind sub-typing does. Sigh. It really only matters if you use (->) in -- a prefix way, thus: (->) Int# Int#. And this is unusual. -funTyConName = mkWiredInName gHC_PRIM - (mkOccNameFS tcName FSLIT("(->)")) - funTyConKey - Nothing -- No parent object - (ATyCon funTyCon) -- Relevant TyCon - BuiltInSyntax + +tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName +coSuperKindTyCon = mkSuperKindTyCon coSuperKindTyConName + +liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName +openTypeKindTyCon = mkKindTyCon openTypeKindTyConName +unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName +ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName +argTypeKindTyCon = mkKindTyCon argTypeKindTyConName + +mkKindTyCon :: Name -> TyCon +mkKindTyCon name = mkVoidPrimTyCon name tySuperKind 0 + +-------------------------- +-- ... and now their names + +tySuperKindTyConName = mkPrimTyConName FSLIT("BOX") tySuperKindTyConKey tySuperKindTyCon +coSuperKindTyConName = mkPrimTyConName FSLIT("COERCION") coSuperKindTyConKey coSuperKindTyCon +liftedTypeKindTyConName = mkPrimTyConName FSLIT("*") liftedTypeKindTyConKey liftedTypeKindTyCon +openTypeKindTyConName = mkPrimTyConName FSLIT("?") openTypeKindTyConKey openTypeKindTyCon +unliftedTypeKindTyConName = mkPrimTyConName FSLIT("#") unliftedTypeKindTyConKey unliftedTypeKindTyCon +ubxTupleKindTyConName = mkPrimTyConName FSLIT("(#)") ubxTupleKindTyConKey ubxTupleKindTyCon +argTypeKindTyConName = mkPrimTyConName FSLIT("??") argTypeKindTyConKey argTypeKindTyCon +funTyConName = mkPrimTyConName FSLIT("(->)") funTyConKey funTyCon + +mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkOccNameFS tcName occ) + key + (ATyCon tycon) + BuiltInSyntax + -- All of the super kinds and kinds are defined in Prim and use BuiltInSyntax, + -- because they are never in scope in the source + +------------------ +-- We also need Kinds and SuperKinds, locally and in TyCon + +kindTyConType :: TyCon -> Type +kindTyConType kind = TyConApp kind [] + +liftedTypeKind = kindTyConType liftedTypeKindTyCon +unliftedTypeKind = kindTyConType unliftedTypeKindTyCon +openTypeKind = kindTyConType openTypeKindTyCon +argTypeKind = kindTyConType argTypeKindTyCon +ubxTupleKind = kindTyConType ubxTupleKindTyCon + +mkArrowKind :: Kind -> Kind -> Kind +mkArrowKind k1 k2 = FunTy k1 k2 + +mkArrowKinds :: [Kind] -> Kind -> Kind +mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds + +tySuperKind, coSuperKind :: SuperKind +tySuperKind = kindTyConType tySuperKindTyCon +coSuperKind = kindTyConType coSuperKindTyCon + +isTySuperKind (NoteTy _ ty) = isTySuperKind ty +isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey +isTySuperKind other = False + +isCoSuperKind :: SuperKind -> Bool +isCoSuperKind (NoteTy _ ty) = isCoSuperKind ty +isCoSuperKind (TyConApp kc []) = kc `hasKey` coSuperKindTyConKey +isCoSuperKind other = False + +------------------- +-- 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} + %************************************************************************ %* * \subsection{The external interface} @@ -308,14 +443,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] 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))) @@ -338,9 +478,12 @@ instance Outputable name => OutputableBndr (IPName name) where ------------------ -- OK, here's the main printer +pprKind = pprType +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 @@ -361,14 +504,22 @@ ppr_type p (FunTy ty1 ty2) ppr_forall_type :: Prec -> Type -> SDoc ppr_forall_type p ty = maybeParen p FunPrec $ - sep [pprForAll tvs, pprThetaArrow ctxt, pprType tau] + sep [pprForAll tvs, pprThetaArrow (ctxt1 ++ ctxt2), pprType tau] where - (tvs, rho) = split1 [] ty - (ctxt, tau) = split2 [] rho - - split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty - split1 tvs (NoteTy _ ty) = split1 tvs ty - split1 tvs ty = (reverse tvs, ty) + (tvs, ctxt1, rho) = split1 [] [] ty + (ctxt2, tau) = split2 [] rho + + -- We need to be extra careful here as equality constraints will occur as + -- type variables with an equality kind. So, while collecting quantified + -- variables, we separate the coercion variables out and turn them into + -- equality predicates. + split1 tvs eqs (ForAllTy tv ty) + | isCoVar tv = split1 tvs (eq:eqs) ty + | otherwise = split1 (tv:tvs) eqs ty + where + PredTy eq = tyVarKind tv + split1 tvs eqs (NoteTy _ ty) = split1 tvs eqs ty + split1 tvs eqs ty = (reverse tvs, reverse eqs, ty) split2 ps (NoteTy _ arg -- Rather a disgusting case `FunTy` res) = split2 ps (arg `FunTy` res) @@ -382,15 +533,37 @@ ppr_tc_app p tc [] ppr_tc_app p tc [ty] | tc `hasKey` listTyConKey = brackets (pprType ty) | tc `hasKey` parrTyConKey = ptext SLIT("[:") <> pprType ty <> ptext SLIT(":]") + | tc `hasKey` liftedTypeKindTyConKey = ptext SLIT("*") + | tc `hasKey` unliftedTypeKindTyConKey = ptext SLIT("#") + | tc `hasKey` openTypeKindTyConKey = ptext SLIT("(?)") + | tc `hasKey` ubxTupleKindTyConKey = ptext SLIT("(#)") + | tc `hasKey` argTypeKindTyConKey = ptext SLIT("??") + 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("")