+\begin{code}
+data Prec = TopPrec -- No parens
+ | FunPrec -- Function args; no parens for tycon apps
+ | TyConPrec -- Tycon args; no parens for atomic
+ deriving( Eq, Ord )
+
+maybeParen :: Prec -> Prec -> SDoc -> SDoc
+maybeParen ctxt_prec inner_prec pretty
+ | ctxt_prec < inner_prec = pretty
+ | otherwise = parens pretty
+
+------------------
+pprType, pprParendType :: Type -> SDoc
+pprType ty = ppr_type TopPrec ty
+pprParendType ty = ppr_type TyConPrec ty
+
+------------------
+pprPred :: PredType -> SDoc
+pprPred (ClassP cls tys) = pprClassPred cls tys
+pprPred (IParam ip ty) = ppr ip <> dcolon <> pprType ty
+
+pprClassPred :: Class -> [Type] -> SDoc
+pprClassPred clas tys = ppr clas <+> sep (map pprParendType tys)
+
+pprTheta :: ThetaType -> SDoc
+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("=>")
+
+------------------
+instance Outputable Type where
+ ppr ty = pprType ty
+
+instance Outputable PredType where
+ ppr = pprPred
+
+instance Outputable name => OutputableBndr (IPName name) where
+ pprBndr _ n = ppr n -- Simple for now
+
+------------------
+ -- OK, here's the main printer
+
+ppr_type :: Prec -> Type -> SDoc
+ppr_type p (TyVarTy tv) = ppr tv
+ppr_type p (PredTy pred) = braces (ppr pred)
+ppr_type p (NoteTy (SynNote ty1) ty2) = ppr_type p ty1
+ppr_type p (NoteTy other ty2) = ppr_type p ty2
+
+ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys
+ppr_type p (NewTcApp tc tys) = ifPprDebug (if isRecursiveTyCon tc
+ then ptext SLIT("<recnt>")
+ else ptext SLIT("<nt>")
+ ) <>
+ ppr_tc_app p tc tys
+
+ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
+ pprType t1 <+> ppr_type TyConPrec t2
+
+ppr_type p (FunTy ty1 ty2)
+ = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
+ maybeParen p FunPrec $
+ sep (ppr_type FunPrec ty1 : ppr_fun_tail ty2)
+ where
+ ppr_fun_tail (FunTy ty1 ty2) = (arrow <+> ppr_type FunPrec ty1) : ppr_fun_tail ty2
+ ppr_fun_tail other_ty = [arrow <+> pprType other_ty]
+
+ppr_type p ty@(ForAllTy _ _)
+ = maybeParen p FunPrec $
+ sep [pprForAll tvs, pprThetaArrow ctxt, pprType tau]
+ where
+ (tvs, rho) = split1 [] ty
+ (ctxt, tau) = split2 [] rho
+
+ split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
+ split1 tvs (NoteTy (FTVNote _) ty) = split1 tvs ty
+ split1 tvs ty = (reverse tvs, ty)
+
+ split2 ps (NoteTy (FTVNote _) 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 (FTVNote _) ty) = split2 ps ty
+ split2 ps ty = (reverse ps, ty)
+
+ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc
+ppr_tc_app p tc []
+ = ppr tc
+ppr_tc_app p tc [ty]
+ | tc `hasKey` listTyConKey = brackets (pprType ty)
+ | tc `hasKey` parrTyConKey = ptext SLIT("[:") <> pprType ty <> ptext SLIT(":]")
+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 <+> sep (map (ppr_type TyConPrec) tys)
+
+-------------------
+pprForAll tvs = ptext SLIT("forall") <+> sep (map pprTvBndr tvs) <> dot
+
+pprTvBndr tv | isLiftedTypeKind kind = ppr tv
+ | otherwise = parens (ppr tv <+> dcolon <+> pprKind kind)
+ where
+ kind = tyVarKind tv