X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FTypeRep.lhs;h=c694dc8b79ef74babcf2da6af4413543f00e1255;hp=5ee0a353eb8767b0a4467473cd6f6e1a2421cf0e;hb=deda0c55629600e886f47a5e90bad67953df1ad8;hpb=ac704fcac946590eef0ec91ae19f3b47d779a75f diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 5ee0a35..c694dc8 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -5,6 +5,13 @@ \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 @@ -15,8 +22,9 @@ module TypeRep ( funTyCon, -- Pretty-printing - pprType, pprParendType, pprTyThingCategory, - pprPred, pprTheta, pprThetaArrow, pprClassPred, + pprType, pprParendType, pprTypeApp, + pprTyThing, pprTyThingCategory, + pprPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred, -- Kinds liftedTypeKind, unliftedTypeKind, openTypeKind, @@ -232,7 +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) + | EqPred Type Type -- Equality predicate (ty1 ~ ty2) type ThetaType = [PredType] \end{code} @@ -251,7 +259,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 @@ -284,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") @@ -395,7 +406,7 @@ isLiftedTypeKind (TyConApp tc []) = isLiftedTypeKindCon tc isLiftedTypeKind other = False isCoercionKind :: Kind -> Bool --- All coercions are of form (ty1 :=: ty2) +-- 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 @@ -432,15 +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] - +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))) @@ -468,7 +483,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 @@ -489,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) @@ -520,11 +543,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("")