X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTypeRep.lhs;h=6b45a5d330ccb67004c66134c91cc1049ce0b9b9;hb=58de6cb725982dd1f57803cc838f233d5fd9c42c;hp=6a9c609eeab41670d7518f610e53df5ff63b3a0c;hpb=c8732b3c99e93c36ad28e23d2b901b794e89542a;p=ghc-hetmet.git diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 6a9c609..6b45a5d 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -15,7 +15,8 @@ module TypeRep ( funTyCon, -- Pretty-printing - pprType, pprParendType, pprTyThingCategory, + pprType, pprParendType, pprTypeApp, + pprTyThing, pprTyThingCategory, pprPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred, -- Kinds @@ -23,6 +24,7 @@ module TypeRep ( argTypeKind, ubxTupleKind, isLiftedTypeKindCon, isLiftedTypeKind, mkArrowKind, mkArrowKinds, isCoercionKind, + coVarPred, -- Kind constructors... liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, @@ -57,6 +59,7 @@ import Class -- others import PrelNames import Outputable +import FastString \end{code} %************************************************************************ @@ -284,8 +287,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") @@ -313,6 +319,15 @@ We define a few wired-in type constructors here to avoid module knots -------------------------- -- First the TyCons... +funTyCon, tySuperKindTyCon, coSuperKindTyCon, liftedTypeKindTyCon, + openTypeKindTyCon, unliftedTypeKindTyCon, + ubxTupleKindTyCon, argTypeKindTyCon + :: TyCon +funTyConName, tySuperKindTyConName, coSuperKindTyConName, liftedTypeKindTyConName, + openTypeKindTyConName, unliftedTypeKindTyConName, + ubxTupleKindTyConName, argTypeKindTyConName + :: Name + 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 @@ -347,6 +362,7 @@ ubxTupleKindTyConName = mkPrimTyConName FSLIT("(#)") ubxTupleKindTyConKey ub argTypeKindTyConName = mkPrimTyConName FSLIT("??") argTypeKindTyConKey argTypeKindTyCon funTyConName = mkPrimTyConName FSLIT("(->)") funTyConKey funTyCon +mkPrimTyConName :: FastString -> Unique -> TyCon -> Name mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkOccNameFS tcName occ) key (ATyCon tycon) @@ -360,6 +376,8 @@ mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkOccNameFS tcName occ) kindTyConType :: TyCon -> Type kindTyConType kind = TyConApp kind [] +liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind :: Kind + liftedTypeKind = kindTyConType liftedTypeKindTyCon unliftedTypeKind = kindTyConType unliftedTypeKindTyCon openTypeKind = kindTyConType openTypeKindTyCon @@ -376,23 +394,25 @@ tySuperKind, coSuperKind :: SuperKind tySuperKind = kindTyConType tySuperKindTyCon coSuperKind = kindTyConType coSuperKindTyCon +isTySuperKind :: SuperKind -> Bool isTySuperKind (NoteTy _ ty) = isTySuperKind ty isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey -isTySuperKind other = False +isTySuperKind _ = False isCoSuperKind :: SuperKind -> Bool isCoSuperKind (NoteTy _ ty) = isCoSuperKind ty isCoSuperKind (TyConApp kc []) = kc `hasKey` coSuperKindTyConKey -isCoSuperKind other = False +isCoSuperKind _ = False ------------------- -- Lastly we need a few functions on Kinds +isLiftedTypeKindCon :: TyCon -> Bool isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey isLiftedTypeKind :: Kind -> Bool isLiftedTypeKind (TyConApp tc []) = isLiftedTypeKindCon tc -isLiftedTypeKind other = False +isLiftedTypeKind _ = False isCoercionKind :: Kind -> Bool -- All coercions are of form (ty1 ~ ty2) @@ -400,7 +420,14 @@ isCoercionKind :: Kind -> Bool -- 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 +isCoercionKind _ = False + +coVarPred :: CoVar -> PredType +coVarPred tv + = ASSERT( isCoVar tv ) + case tyVarKind tv of + PredTy eq -> eq -- There shouldn't even be a NoteTy in the way + other -> pprPanic "coVarPred" (ppr tv $$ ppr other) \end{code} @@ -432,15 +459,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))) @@ -463,13 +494,14 @@ instance Outputable name => OutputableBndr (IPName name) where ------------------ -- OK, here's the main printer +pprKind, pprParendKind :: Kind -> SDoc pprKind = pprType pprParendKind = pprParendType ppr_type :: Prec -> Type -> SDoc -ppr_type p (TyVarTy tv) = ppr tv -ppr_type p (PredTy pred) = ifPprDebug (ptext SLIT("")) <> (ppr pred) -ppr_type p (NoteTy other ty2) = ppr_type p ty2 +ppr_type _ (TyVarTy tv) = ppr tv +ppr_type _ (PredTy pred) = ifPprDebug (ptext SLIT("")) <> (ppr pred) +ppr_type p (NoteTy _ ty2) = ifPprDebug (ptext SLIT("")) <> ppr_type p ty2 ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $ @@ -494,20 +526,27 @@ ppr_forall_type p ty (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) + -- 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 (ForAllTy tv ty) + | not (isCoVar tv) = split1 (tv:tvs) ty + split1 tvs (NoteTy _ ty) = split1 tvs ty + split1 tvs ty = (reverse tvs, ty) split2 ps (NoteTy _ arg -- Rather a disgusting case - `FunTy` res) = split2 ps (arg `FunTy` res) - split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty - split2 ps (NoteTy _ ty) = split2 ps ty - split2 ps ty = (reverse ps, ty) + `FunTy` res) = split2 ps (arg `FunTy` res) + split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty + split2 ps (ForAllTy tv ty) + | isCoVar tv = split2 (coVarPred tv : ps) ty + split2 ps (NoteTy _ ty) = split2 ps ty + split2 ps ty = (reverse ps, ty) ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc -ppr_tc_app p tc [] +ppr_tc_app _ tc [] = ppr_tc tc -ppr_tc_app p tc [ty] +ppr_tc_app _ tc [ty] | tc `hasKey` listTyConKey = brackets (pprType ty) | tc `hasKey` parrTyConKey = ptext SLIT("[:") <> pprType ty <> ptext SLIT(":]") | tc `hasKey` liftedTypeKindTyConKey = ptext SLIT("*") @@ -520,11 +559,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("") @@ -532,9 +587,11 @@ ppr_tc tc = parenSymOcc (getOccName tc) (pp_nt_debug <> ppr tc) | otherwise = empty ------------------- +pprForAll :: [TyVar] -> SDoc pprForAll [] = empty pprForAll tvs = ptext SLIT("forall") <+> sep (map pprTvBndr tvs) <> dot +pprTvBndr :: TyVar -> SDoc pprTvBndr tv | isLiftedTypeKind kind = ppr tv | otherwise = parens (ppr tv <+> dcolon <+> pprKind kind) where