X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTypeRep.lhs;h=6a9c609eeab41670d7518f610e53df5ff63b3a0c;hb=272fb49ecfeffe7aaa66b9b61bab12d8a858458d;hp=9110d68ad8309e2126dbf85d0a499c297097da8b;hpb=b00b5bc04ff36a551552470060064f0b7d84ca30;p=ghc-hetmet.git

diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 9110d68..6a9c609 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -1,4 +1,5 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1998
 %
 \section[TypeRep]{Type - friends' interface}
@@ -14,14 +15,14 @@ module TypeRep (
 	funTyCon,
 
 	-- Pretty-printing
-	pprType, pprParendType, pprTyThingCategory,
-	pprPred, pprTheta, pprThetaArrow, pprClassPred,
+	pprType, pprParendType, pprTyThingCategory, 
+	pprPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
 
 	-- Kinds
 	liftedTypeKind, unliftedTypeKind, openTypeKind,
         argTypeKind, ubxTupleKind,
 	isLiftedTypeKindCon, isLiftedTypeKind,
-	mkArrowKind, mkArrowKinds,
+	mkArrowKind, mkArrowKinds, isCoercionKind,
 
         -- Kind constructors...
         liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
@@ -43,24 +44,18 @@ module TypeRep (
 #include "HsVersions.h"
 
 import {-# SOURCE #-} DataCon( DataCon, dataConName )
--- friends:
 
-import Var	  ( Var, Id, TyVar, tyVarKind )
-import VarSet     ( TyVarSet )
-import Name	  ( Name, NamedThing(..), BuiltInSyntax(..), mkWiredInName )
-import OccName	  ( mkOccNameFS, tcName, parenSymOcc )
-import BasicTypes ( IPName, tupleParens )
-import TyCon	  ( TyCon, mkFunTyCon, tyConArity, tupleTyConBoxity, isTupleTyCon, 
-		    isRecursiveTyCon, isNewTyCon, mkVoidPrimTyCon, 
-		    mkSuperKindTyCon )
-import Class	  ( Class )
+-- friends:
+import Var
+import VarSet
+import Name
+import OccName
+import BasicTypes
+import TyCon
+import Class
 
 -- others
-import PrelNames  ( gHC_PRIM, funTyConKey, tySuperKindTyConKey, 
-                    coSuperKindTyConKey, liftedTypeKindTyConKey,
-                    openTypeKindTyConKey, unliftedTypeKindTyConKey,
-                    ubxTupleKindTyConKey, argTypeKindTyConKey, listTyConKey, 
-                    parrTyConKey, hasKey )
+import PrelNames
 import Outputable
 \end{code}
 
@@ -237,7 +232,7 @@ Predicates are represented inside GHC by PredType:
 data PredType 
   = ClassP Class [Type]		-- Class predicate
   | IParam (IPName Name) Type	-- Implicit parameter
-  | EqPred Type Type		-- Equality predicate (ty1 :=: ty2)
+  | EqPred Type Type		-- Equality predicate (ty1 ~ ty2)
 
 type ThetaType = [PredType]
 \end{code}
@@ -256,7 +251,7 @@ represented by evidence (a dictionary, for example, of type (predRepTy p).
 
 Note [Equality predicates]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
-	forall a b. (a :=: S b) => a -> b
+	forall a b. (a ~ S b) => a -> b
 could be represented by
 	ForAllTy a (ForAllTy b (FunTy (PredTy (EqPred a (S b))) ...))
 OR
@@ -391,14 +386,21 @@ isCoSuperKind (TyConApp kc []) = kc `hasKey` coSuperKindTyConKey
 isCoSuperKind other            = False
 
 -------------------
--- lastly we need a few functions on Kinds
+-- Lastly we need a few functions on Kinds
 
 isLiftedTypeKindCon tc    = tc `hasKey` liftedTypeKindTyConKey
 
+isLiftedTypeKind :: Kind -> Bool
 isLiftedTypeKind (TyConApp tc []) = isLiftedTypeKindCon tc
 isLiftedTypeKind other            = False
 
-
+isCoercionKind :: Kind -> Bool
+-- All coercions are of form (ty1 ~ ty2)
+-- This function is here rather than in Coercion, 
+-- 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
 \end{code}
 
 
@@ -434,7 +436,7 @@ pprParendType ty = ppr_type TyConPrec ty
 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]
+pprPred (EqPred ty1 ty2) = sep [ppr ty1, nest 2 (ptext SLIT("~")), ppr ty2]
 
 pprClassPred :: Class -> [Type] -> SDoc
 pprClassPred clas tys = parenSymOcc (getOccName clas) (ppr clas) 
@@ -466,7 +468,7 @@ pprParendKind = pprParendType
 
 ppr_type :: Prec -> Type -> SDoc
 ppr_type p (TyVarTy tv)       = ppr tv
-ppr_type p (PredTy pred)      = braces (ppr pred)
+ppr_type p (PredTy pred)      = ifPprDebug (ptext SLIT("<pred>")) <> (ppr pred)
 ppr_type p (NoteTy other ty2) = ppr_type p ty2
 ppr_type p (TyConApp tc tys)  = ppr_tc_app p tc tys