[project @ 2005-07-19 16:44:50 by simonpj]
[ghc-hetmet.git] / ghc / compiler / types / TypeRep.lhs
index 7bbbc5a..f5bb325 100644 (file)
@@ -33,7 +33,7 @@ import Kind
 import Var       ( Var, Id, TyVar, tyVarKind )
 import VarSet     ( TyVarSet )
 import Name      ( Name, NamedThing(..), BuiltInSyntax(..), mkWiredInName )
-import OccName   ( mkOccFS, tcName )
+import OccName   ( mkOccFS, tcName, parenSymOcc )
 import BasicTypes ( IPName, tupleParens )
 import TyCon     ( TyCon, mkFunTyCon, tyConArity, tupleTyConBoxity, isTupleTyCon, isRecursiveTyCon, isNewTyCon )
 import Class     ( Class )
@@ -153,7 +153,7 @@ data Type
                        -- (or NoteTy of these)
 
   | TyConApp           -- Application of a TyCon, including newtypes
-       TyCon           -- *Invariant* saturated appliations of FunTyCon and
+       TyCon           --  *Invariant* saturated appliations of FunTyCon and
                        --      synonyms have their own constructors, below.
                        -- However, *unsaturated* type synonyms, and FunTyCons
                        --      do appear as TyConApps.  (Unsaturated type synonyms
@@ -317,7 +317,8 @@ 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)
+pprClassPred clas tys = parenSymOcc (getOccName clas) (ppr clas) 
+                       <+> sep (map pprParendType tys)
 
 pprTheta :: ThetaType -> SDoc
 pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
@@ -351,6 +352,9 @@ ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys
 ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
                           pprType t1 <+> ppr_type TyConPrec t2
 
+ppr_type p ty@(ForAllTy _ _)       = ppr_forall_type p ty
+ppr_type p ty@(FunTy (PredTy _) _) = ppr_forall_type p ty
+
 ppr_type p (FunTy ty1 ty2)
   = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
     maybeParen p FunPrec $
@@ -359,7 +363,8 @@ ppr_type p (FunTy ty1 ty2)
     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 _ _)  
+ppr_forall_type :: Prec -> Type -> SDoc
+ppr_forall_type p ty
   = maybeParen p FunPrec $
     sep [pprForAll tvs, pprThetaArrow ctxt, pprType tau]
   where
@@ -390,14 +395,15 @@ ppr_tc_app p tc tys
     ppr_tc tc <+> sep (map (ppr_type TyConPrec) tys)
 
 ppr_tc :: TyCon -> SDoc
-ppr_tc tc
-  | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc 
-                               then ptext SLIT("<recnt>")
-                               else ptext SLIT("<nt>")
-                   ) <> ppr tc
-  | otherwise = ppr tc
-                              
+ppr_tc tc = parenSymOcc (getOccName tc) (pp_nt_debug <> ppr tc)
+  where
+   pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc 
+                                            then ptext SLIT("<recnt>")
+                                            else ptext SLIT("<nt>"))
+              | otherwise     = empty
+
 -------------------
+pprForAll []  = empty
 pprForAll tvs = ptext SLIT("forall") <+> sep (map pprTvBndr tvs) <> dot
 
 pprTvBndr tv | isLiftedTypeKind kind = ppr tv