X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTypeRep.lhs;h=33723120e5d3d4fd5e142697e98bfaa6b3c8dad4;hb=f83010b119096699d1efef2f7bb45460719c48f9;hp=cc8e4beb3ad757baf20b3dbe3baba2806301fa7b;hpb=cd290fc88d35d5a32c994664baa56a5eae250e9e;p=ghc-hetmet.git

diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index cc8e4be..3372312 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -433,17 +433,19 @@ pprType, pprParendType :: Type -> SDoc
 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)))
@@ -523,10 +525,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 (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>")