\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
-- Pretty-printing
pprType, pprParendType, pprTypeApp,
- pprTyThingCategory,
+ pprTyThing, pprTyThingCategory,
pprPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
-- Kinds
| 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")
pprType ty = ppr_type TopPrec ty
pprParendType ty = ppr_type TyConPrec ty
-pprTypeApp :: SDoc -> [Type] -> SDoc
-pprTypeApp pp tys = hang pp 2 (sep (map pprParendType tys))
+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 = pprTypeApp (parenSymOcc (getOccName clas) (ppr clas)) 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)))
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)
| isTupleTyCon tc && tyConArity tc == length tys
= tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
| otherwise
- = maybeParen p TyConPrec (pprTypeApp (ppr_tc tc) 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("<recnt>")