X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTypeRep.lhs;h=7b5324bf340eae9ee9b42fa860d265da460c77fa;hb=d365fe1e7f9677715a9249b6dc86aefd2e09018e;hp=6b45a5d330ccb67004c66134c91cc1049ce0b9b9;hpb=4380fd6ff23f6e079c01b1398b8ebb4c3bbc3f7a;p=ghc-hetmet.git diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 6b45a5d..7b5324b 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -7,7 +7,7 @@ \begin{code} module TypeRep ( TyThing(..), - Type(..), TyNote(..), -- Representation visible + Type(..), PredType(..), -- to friends Kind, ThetaType, -- Synonyms @@ -49,7 +49,6 @@ import {-# SOURCE #-} DataCon( DataCon, dataConName ) -- friends: import Var -import VarSet import Name import OccName import BasicTypes @@ -169,7 +168,6 @@ data Type | AppTy Type -- Function is *not* a TyConApp Type -- It must be another AppTy, or TyVarTy - -- (or NoteTy of these) | TyConApp -- Application of a TyCon, including newtypes *and* synonyms TyCon -- *Invariant* saturated appliations of FunTyCon and @@ -195,10 +193,6 @@ data Type -- 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 [...] @@ -207,8 +201,6 @@ type Kind = Type -- Invariant: a kind is always 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} ------------------------------------- @@ -294,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 @@ -353,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) @@ -395,12 +387,10 @@ tySuperKind = kindTyConType tySuperKindTyCon coSuperKind = kindTyConType coSuperKindTyCon isTySuperKind :: SuperKind -> Bool -isTySuperKind (NoteTy _ ty) = isTySuperKind ty isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey isTySuperKind _ = False isCoSuperKind :: SuperKind -> Bool -isCoSuperKind (NoteTy _ ty) = isCoSuperKind ty isCoSuperKind (TyConApp kc []) = kc `hasKey` coSuperKindTyConKey isCoSuperKind _ = False @@ -418,7 +408,6 @@ 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 _ = False @@ -426,7 +415,7 @@ 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 + PredTy eq -> eq other -> pprPanic "coVarPred" (ppr tv $$ ppr other) \end{code} @@ -469,7 +458,7 @@ 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 = ppr_type_app TopPrec (getName clas) (ppr clas) tys @@ -479,7 +468,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 @@ -500,8 +489,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 p (NoteTy _ ty2) = ifPprDebug (ptext SLIT("")) <> ppr_type p ty2 +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,15 +520,11 @@ ppr_forall_type p ty -- 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 (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 @@ -548,12 +532,12 @@ 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 @@ -582,14 +566,14 @@ ppr_naked_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