X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTypeRep.lhs;h=48481e2bb561c771035fc95a46753a8a666d8254;hb=5660d1ddb2f991d57d75252e3ed14d80914b7615;hp=4927dcc845a6daea4fb87c1d3df087da49f7b70a;hpb=467f588c25e6d7825a11eff018a67727b3dea71b;p=ghc-hetmet.git diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 4927dcc..48481e2 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -286,10 +286,10 @@ pprTyThing :: TyThing -> SDoc pprTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing)) pprTyThingCategory :: TyThing -> SDoc -pprTyThingCategory (ATyCon _) = ptext SLIT("Type constructor") -pprTyThingCategory (AClass _) = ptext SLIT("Class") -pprTyThingCategory (AnId _) = ptext SLIT("Identifier") -pprTyThingCategory (ADataCon _) = ptext SLIT("Data constructor") +pprTyThingCategory (ATyCon _) = ptext (sLit "Type constructor") +pprTyThingCategory (AClass _) = ptext (sLit "Class") +pprTyThingCategory (AnId _) = ptext (sLit "Identifier") +pprTyThingCategory (ADataCon _) = ptext (sLit "Data constructor") instance NamedThing TyThing where -- Can't put this with the type getName (AnId id) = getName id -- decl, because the DataCon instance @@ -345,14 +345,14 @@ 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 +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 :: FastString -> Unique -> TyCon -> Name mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkOccNameFS tcName occ) @@ -448,19 +448,18 @@ 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 +pprTypeApp :: NamedThing a => a -> [Type] -> SDoc +-- The first arg is the tycon, or sometimes class +-- Print infix if the tycon/class looks like an operator +pprTypeApp tc tys = ppr_type_app TopPrec (getName 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 = ppr_type_app TopPrec (getName clas) (ppr clas) tys +pprClassPred clas tys = ppr_type_app TopPrec (getName clas) tys pprTheta :: ThetaType -> SDoc pprTheta theta = parens (sep (punctuate comma (map pprPred theta))) @@ -468,7 +467,7 @@ pprTheta theta = parens (sep (punctuate comma (map pprPred theta))) pprThetaArrow :: ThetaType -> SDoc pprThetaArrow theta | null theta = empty - | otherwise = parens (sep (punctuate comma (map pprPred theta))) <+> ptext SLIT("=>") + | otherwise = parens (sep (punctuate comma (map pprPred theta))) <+> ptext (sLit "=>") ------------------ instance Outputable Type where @@ -489,7 +488,7 @@ pprParendKind = pprParendType ppr_type :: Prec -> Type -> SDoc ppr_type _ (TyVarTy tv) = ppr tv -ppr_type _ (PredTy pred) = ifPprDebug (ptext SLIT("")) <> (ppr pred) +ppr_type _ (PredTy pred) = ifPprDebug (ptext (sLit "")) <> (ppr pred) ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $ @@ -532,48 +531,45 @@ ppr_tc_app _ tc [] = ppr_tc tc 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("*") - | tc `hasKey` unliftedTypeKindTyConKey = ptext SLIT("#") - | tc `hasKey` openTypeKindTyConKey = ptext SLIT("(?)") - | tc `hasKey` ubxTupleKindTyConKey = ptext SLIT("(#)") - | tc `hasKey` argTypeKindTyConKey = ptext SLIT("??") + | 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 - = ppr_type_app p (getName tc) (ppr_naked_tc tc) tys + = ppr_type_app p (getName tc) tys -ppr_type_app :: Prec -> Name -> SDoc -> [Type] -> SDoc -ppr_type_app p tc pp_tc tys +ppr_type_app :: Prec -> Name -> [Type] -> SDoc +-- Used for classes as well as types; that's why it's separate from ppr_tc_app +ppr_type_app p 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]) + pprInfixVar True (ppr tc) <+> ppr_type FunPrec ty2]) | otherwise - = maybeParen p TyConPrec (hang paren_tc 2 (sep (map pprParendType tys))) + = maybeParen p TyConPrec (hang (pprPrefixVar is_sym_occ (ppr 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) (ppr_naked_tc tc) - -ppr_naked_tc :: TyCon -> SDoc -- No brackets for SymOcc -ppr_naked_tc tc +ppr_tc :: TyCon -> SDoc -- No brackets for SymOcc +ppr_tc tc = pp_nt_debug <> ppr tc where pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc - then ptext SLIT("") - else ptext SLIT("")) + then ptext (sLit "") + else ptext (sLit "")) | otherwise = empty ------------------- pprForAll :: [TyVar] -> SDoc pprForAll [] = empty -pprForAll tvs = ptext SLIT("forall") <+> sep (map pprTvBndr tvs) <> dot +pprForAll tvs = ptext (sLit "forall") <+> sep (map pprTvBndr tvs) <> dot pprTvBndr :: TyVar -> SDoc pprTvBndr tv | isLiftedTypeKind kind = ppr tv