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

diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 3372312..c694dc8 100644
--- 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")
@@ -494,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)