Minor refactoring: give an explicit name to the pretty-printing function for TyThing...

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

diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index cc8e4be..c694dc8 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 
@@ -16,7 +23,7 @@ module TypeRep (
 
        -- Pretty-printing
        pprType, pprParendType, pprTypeApp,
-       pprTyThingCategory, 
+       pprTyThing, pprTyThingCategory, 
        pprPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
 
        -- Kinds
@@ -285,8 +292,11 @@ data TyThing = AnId     Id
             | ATyCon   TyCon
             | AClass   Class
 
-instance Outputable TyThing where
-  ppr thing = pprTyThingCategory thing <+> quotes (ppr (getName thing))
+instance Outputable TyThing where 
+  ppr = pprTyThing
+
+pprTyThing :: TyThing -> SDoc
+pprTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing))
 
 pprTyThingCategory :: TyThing -> SDoc
 pprTyThingCategory (ATyCon _)  = ptext SLIT("Type constructor")
@@ -433,17 +443,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)))
@@ -492,14 +504,22 @@ ppr_type p (FunTy ty1 ty2)
 ppr_forall_type :: Prec -> Type -> SDoc
 ppr_forall_type p ty
   = maybeParen p FunPrec $
-    sep [pprForAll tvs, pprThetaArrow ctxt, pprType tau]
+    sep [pprForAll tvs, pprThetaArrow (ctxt1 ++ ctxt2), pprType tau]
   where
-    (tvs,  rho) = split1 [] ty
-    (ctxt, tau) = split2 [] rho
-
-    split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
-    split1 tvs (NoteTy _ ty)    = split1 tvs ty
-    split1 tvs ty              = (reverse tvs, ty)
+    (tvs, ctxt1, rho) = split1 [] [] ty
+    (ctxt2, tau)      = split2 [] rho
+
+    -- We need to be extra careful here as equality constraints will occur as
+    -- type variables with an equality kind.  So, while collecting quantified
+    -- variables, we separate the coercion variables out and turn them into
+    -- equality predicates.
+    split1 tvs eqs (ForAllTy tv ty) 
+      | isCoVar tv               = split1 tvs (eq:eqs) ty
+      | otherwise                = split1 (tv:tvs) eqs ty
+      where
+        PredTy eq = tyVarKind tv
+    split1 tvs eqs (NoteTy _ ty) = split1 tvs eqs ty
+    split1 tvs eqs ty           = (reverse tvs, reverse eqs, ty)
  
     split2 ps (NoteTy _ arg    -- Rather a disgusting case
               `FunTy` res)           = split2 ps (arg `FunTy` res)
@@ -523,10 +543,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>")