X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTypeRep.lhs;h=6b45a5d330ccb67004c66134c91cc1049ce0b9b9;hb=937eb1f1386f12c729c6d819417fe81bc4786b9f;hp=39fe48c067e6da9c03bc89ad26b22c122871bc8c;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf;p=ghc-hetmet.git

diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 39fe48c..6b45a5d 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -5,13 +5,6 @@
 \section[TypeRep]{Type - friends' interface}
 
 \begin{code}
-{-# OPTIONS_GHC -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/WorkingConventions#Warnings
--- for details
-
 module TypeRep (
 	TyThing(..), 
 	Type(..), TyNote(..), 		-- Representation visible 
@@ -23,7 +16,7 @@ module TypeRep (
 
 	-- Pretty-printing
 	pprType, pprParendType, pprTypeApp,
-	pprTyThingCategory, 
+	pprTyThing, pprTyThingCategory, 
 	pprPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
 
 	-- Kinds
@@ -31,6 +24,7 @@ module TypeRep (
         argTypeKind, ubxTupleKind,
 	isLiftedTypeKindCon, isLiftedTypeKind,
 	mkArrowKind, mkArrowKinds, isCoercionKind,
+  	coVarPred,
 
         -- Kind constructors...
         liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
@@ -65,6 +59,7 @@ import Class
 -- others
 import PrelNames
 import Outputable
+import FastString
 \end{code}
 
 %************************************************************************
@@ -292,8 +287,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")
@@ -321,6 +319,15 @@ We define a few wired-in type constructors here to avoid module knots
 --------------------------
 -- First the TyCons...
 
+funTyCon, tySuperKindTyCon, coSuperKindTyCon, liftedTypeKindTyCon,
+      openTypeKindTyCon, unliftedTypeKindTyCon,
+      ubxTupleKindTyCon, argTypeKindTyCon
+   :: TyCon
+funTyConName, tySuperKindTyConName, coSuperKindTyConName, liftedTypeKindTyConName,
+      openTypeKindTyConName, unliftedTypeKindTyConName,
+      ubxTupleKindTyConName, argTypeKindTyConName
+   :: Name
+
 funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind)
 	-- You might think that (->) should have type (?? -> ? -> *), and you'd be right
 	-- But if we do that we get kind errors when saying
@@ -355,6 +362,7 @@ ubxTupleKindTyConName     = mkPrimTyConName FSLIT("(#)") ubxTupleKindTyConKey ub
 argTypeKindTyConName      = mkPrimTyConName FSLIT("??") argTypeKindTyConKey argTypeKindTyCon
 funTyConName              = mkPrimTyConName FSLIT("(->)") funTyConKey funTyCon
 
+mkPrimTyConName :: FastString -> Unique -> TyCon -> Name
 mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkOccNameFS tcName occ) 
 					      key 
 					      (ATyCon tycon)
@@ -368,6 +376,8 @@ mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkOccNameFS tcName occ)
 kindTyConType :: TyCon -> Type
 kindTyConType kind = TyConApp kind []
 
+liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind :: Kind
+
 liftedTypeKind   = kindTyConType liftedTypeKindTyCon
 unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
 openTypeKind     = kindTyConType openTypeKindTyCon
@@ -384,23 +394,25 @@ tySuperKind, coSuperKind :: SuperKind
 tySuperKind = kindTyConType tySuperKindTyCon 
 coSuperKind = kindTyConType coSuperKindTyCon 
 
+isTySuperKind :: SuperKind -> Bool
 isTySuperKind (NoteTy _ ty)    = isTySuperKind ty
 isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey
-isTySuperKind other            = False
+isTySuperKind _                = False
 
 isCoSuperKind :: SuperKind -> Bool
 isCoSuperKind (NoteTy _ ty)    = isCoSuperKind ty
 isCoSuperKind (TyConApp kc []) = kc `hasKey` coSuperKindTyConKey
-isCoSuperKind other            = False
+isCoSuperKind _                = False
 
 -------------------
 -- Lastly we need a few functions on Kinds
 
+isLiftedTypeKindCon :: TyCon -> Bool
 isLiftedTypeKindCon tc    = tc `hasKey` liftedTypeKindTyConKey
 
 isLiftedTypeKind :: Kind -> Bool
 isLiftedTypeKind (TyConApp tc []) = isLiftedTypeKindCon tc
-isLiftedTypeKind other            = False
+isLiftedTypeKind _                = False
 
 isCoercionKind :: Kind -> Bool
 -- All coercions are of form (ty1 ~ ty2)
@@ -408,7 +420,14 @@ isCoercionKind :: Kind -> Bool
 -- because it's used in a knot-tied way to enforce invariants in Var
 isCoercionKind (NoteTy _ k)         = isCoercionKind k
 isCoercionKind (PredTy (EqPred {})) = True
-isCoercionKind other		    = False
+isCoercionKind _                    = False
+
+coVarPred :: CoVar -> PredType
+coVarPred tv
+  = ASSERT( isCoVar tv )
+    case tyVarKind tv of
+	PredTy eq -> eq		-- There shouldn't even be a NoteTy in the way
+	other	  -> pprPanic "coVarPred" (ppr tv $$ ppr other)
 \end{code}
 
 
@@ -475,13 +494,14 @@ instance Outputable name => OutputableBndr (IPName name) where
 ------------------
 	-- OK, here's the main printer
 
+pprKind, pprParendKind :: Kind -> SDoc
 pprKind = pprType
 pprParendKind = pprParendType
 
 ppr_type :: Prec -> Type -> SDoc
-ppr_type p (TyVarTy tv)       = ppr tv
-ppr_type p (PredTy pred)      = ifPprDebug (ptext SLIT("<pred>")) <> (ppr pred)
-ppr_type p (NoteTy other ty2) = ppr_type p ty2
+ppr_type _ (TyVarTy tv)       = ppr tv
+ppr_type _ (PredTy pred)      = ifPprDebug (ptext SLIT("<pred>")) <> (ppr pred)
+ppr_type p (NoteTy _ ty2)     = ifPprDebug (ptext SLIT("<note>")) <> ppr_type p ty2
 ppr_type p (TyConApp tc tys)  = ppr_tc_app p tc tys
 
 ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
@@ -506,20 +526,27 @@ ppr_forall_type p ty
     (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)
+    -- 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 (ForAllTy tv ty) 
+      | not (isCoVar tv)     = split1 (tv:tvs) ty
+    split1 tvs (NoteTy _ ty) = split1 tvs ty
+    split1 tvs ty	     = (reverse tvs, ty)
  
     split2 ps (NoteTy _ arg 	-- Rather a disgusting case
-	       `FunTy` res) 	      = split2 ps (arg `FunTy` res)
-    split2 ps (PredTy p `FunTy` ty)   = split2 (p:ps) ty
-    split2 ps (NoteTy _ ty) 	      = split2 ps ty
-    split2 ps ty		      = (reverse ps, ty)
+	       `FunTy` res) 	    = split2 ps (arg `FunTy` res)
+    split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty
+    split2 ps (ForAllTy tv ty) 
+	| isCoVar tv		    = split2 (coVarPred tv : ps) ty
+    split2 ps (NoteTy _ ty) 	    = split2 ps ty
+    split2 ps ty		    = (reverse ps, ty)
 
 ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc
-ppr_tc_app p tc [] 
+ppr_tc_app _ tc []
   = ppr_tc tc
-ppr_tc_app p tc [ty] 
+ppr_tc_app _ tc [ty]
   | tc `hasKey` listTyConKey = brackets (pprType ty)
   | tc `hasKey` parrTyConKey = ptext SLIT("[:") <> pprType ty <> ptext SLIT(":]")
   | tc `hasKey` liftedTypeKindTyConKey   = ptext SLIT("*")
@@ -560,9 +587,11 @@ ppr_naked_tc tc
 	       | otherwise     = empty
 
 -------------------
+pprForAll :: [TyVar] -> SDoc
 pprForAll []  = empty
 pprForAll tvs = ptext SLIT("forall") <+> sep (map pprTvBndr tvs) <> dot
 
+pprTvBndr :: TyVar -> SDoc
 pprTvBndr tv | isLiftedTypeKind kind = ppr tv
 	     | otherwise	     = parens (ppr tv <+> dcolon <+> pprKind kind)
 	     where