From: simonpj@microsoft.com <unknown>
Date: Mon, 25 Jun 2007 15:28:58 +0000 (+0000)
Subject: Print infix type constructors in an infix way
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=b15724ad3cae2a14c265683e8bb6f7d639dac251

Print infix type constructors in an infix way

Fixes Trac #1425.  The printer for types doesn't know about fixities.
(It could be educated to know, but it doesn't at the moment.)  So it
treats all infix tycons as of precedence less than application and function
arrrow.

I took a slight shortcut and reused function-arrow prededence, so I think
you may get
	T -> T :% T
meaning
	T -> (T :% T)

If that becomes a problem we can fix it.
---

diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index 86c6f4c..4b309b6 100644
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -69,7 +69,7 @@ pprTyThingHdr exts (AClass cls)       = pprClassHdr   exts cls
         
 pprTyConHdr exts tyCon
   | Just (fam_tc, tys) <- tyConFamInst_maybe tyCon
-  = ptext keyword <+> ptext SLIT("instance") <+> pprTypeApp (ppr_bndr tyCon) tys
+  = ptext keyword <+> ptext SLIT("instance") <+> pprTypeApp tyCon (ppr_bndr tyCon) tys
   | otherwise
   = ptext keyword <+> opt_family <+> ppr_bndr tyCon <+> hsep (map ppr vars)
   where
diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index 28a8758..330e73b 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -707,7 +707,7 @@ wrongThingErr expected thing name
 		ptext SLIT("used as a") <+> text expected)
 
 famInstNotFound tycon tys what
-  = failWithTc (msg <+> quotes (pprTypeApp (ppr tycon) tys))
+  = failWithTc (msg <+> quotes (pprTypeApp tycon (ppr tycon) tys))
   where
     msg = ptext $ if length what > 1 
 		  then SLIT("More than one family instance for")
diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 8751e40..ee55583 100644
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -95,7 +95,7 @@ pprFamInstHdr :: FamInst -> SDoc
 pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
   = pprTyConSort <+> pprHead
   where
-    pprHead = pprTypeApp (parenSymOcc (getOccName fam) (ppr fam)) tys
+    pprHead = pprTypeApp fam (ppr fam) tys
     pprTyConSort | isDataTyCon tycon = ptext SLIT("data instance")
 		 | isNewTyCon  tycon = ptext SLIT("newtype instance")
 		 | isSynTyCon  tycon = ptext SLIT("type instance")
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>")