Fix CodingStyle#Warnings URLs

[ghc-hetmet.git] / compiler / types / TypeRep.lhs

diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index cc8e4be..a3a46b3 100644 (file)
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -5,6 +5,13 @@
 \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 
@@ -433,17 +440,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 +532,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>")