X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=20dbb005f7e061f9daf74963efe2c8e5476f5c44;hb=550421384b8364cdaf3135f7859c9f7d7ee1fff1;hp=333b589403c4e9a65ddccc3d6a6ef59d6dc49cf0;hpb=98688c6e8fd33f31c51218cf93cbf03fe3a5e73d;p=ghc-hetmet.git

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 333b589..20dbb00 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -15,6 +15,7 @@ module Type (
 	openKindCon, 					-- :: KX
 	typeCon,					-- :: BX -> KX
 	liftedTypeKind, unliftedTypeKind, openTypeKind,	-- :: KX
+	isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, isSuperKind,
 	mkArrowKind, mkArrowKinds,			-- :: KX -> KX -> KX
 	isTypeKind, isAnyTypeKind,
 	funTyCon,
@@ -41,7 +42,7 @@ module Type (
 	applyTy, applyTys, isForAllTy, dropForAlls,
 
 	-- Source types
-	isPredTy, predTypeRep, mkPredTy, mkPredTys,
+	predTypeRep, mkPredTy, mkPredTys,
 
 	-- Newtypes
 	splitRecNewType_maybe,
@@ -65,8 +66,12 @@ module Type (
 	eqType, eqKind, 
 
 	-- Seq
-	seqType, seqTypes
+	seqType, seqTypes,
 
+	-- Pretty-printing
+	pprKind, pprParendKind,
+	pprType, pprParendType,
+	pprPred, pprTheta, pprThetaArrow, pprClassPred
     ) where
 
 #include "HsVersions.h"
@@ -182,8 +187,7 @@ invariant: use it.
 
 \begin{code}
 mkAppTy orig_ty1 orig_ty2
-  = ASSERT2( not (isPredTy orig_ty1), crudePprType orig_ty1 )	-- Source types are of kind *
-    mk_app orig_ty1
+  = mk_app orig_ty1
   where
     mk_app (NoteTy _ ty1)    = mk_app ty1
     mk_app (NewTcApp tc tys) = NewTcApp tc (tys ++ [orig_ty2])
@@ -206,8 +210,7 @@ mkAppTys orig_ty1 []	    = orig_ty1
 	--   returns to (Ratio Integer), which has needlessly lost
 	--   the Rational part.
 mkAppTys orig_ty1 orig_tys2
-  = ASSERT( not (isPredTy orig_ty1) )	-- Source types are of kind *
-    mk_app orig_ty1
+  = mk_app orig_ty1
   where
     mk_app (NoteTy _ ty1)    = mk_app ty1
     mk_app (NewTcApp tc tys) = NewTcApp tc (tys ++ orig_tys2)
@@ -267,7 +270,7 @@ splitFunTy (FunTy arg res)   = (arg, res)
 splitFunTy (NoteTy _ ty)     = splitFunTy ty
 splitFunTy (PredTy p)        = splitFunTy (predTypeRep p)
 splitFunTy (NewTcApp tc tys) = splitFunTy (newTypeRep tc tys)
-splitFunTy other	     = pprPanic "splitFunTy" (crudePprType other)
+splitFunTy other	     = pprPanic "splitFunTy" (ppr other)
 
 splitFunTy_maybe :: Type -> Maybe (Type, Type)
 splitFunTy_maybe (FunTy arg res)   = Just (arg, res)
@@ -293,21 +296,21 @@ zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
     split acc xs     nty (NoteTy _ ty)     = split acc           xs nty ty
     split acc xs     nty (PredTy p)        = split acc           xs nty (predTypeRep p)
     split acc xs     nty (NewTcApp tc tys) = split acc           xs nty (newTypeRep tc tys)
-    split acc (x:xs) nty ty                = pprPanic "zipFunTys" (ppr orig_xs <+> crudePprType orig_ty)
+    split acc (x:xs) nty ty                = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty)
     
 funResultTy :: Type -> Type
 funResultTy (FunTy arg res)   = res
 funResultTy (NoteTy _ ty)     = funResultTy ty
 funResultTy (PredTy p)        = funResultTy (predTypeRep p)
 funResultTy (NewTcApp tc tys) = funResultTy (newTypeRep tc tys)
-funResultTy ty		      = pprPanic "funResultTy" (crudePprType ty)
+funResultTy ty		      = pprPanic "funResultTy" (ppr ty)
 
 funArgTy :: Type -> Type
 funArgTy (FunTy arg res)   = arg
 funArgTy (NoteTy _ ty)     = funArgTy ty
 funArgTy (PredTy p)        = funArgTy (predTypeRep p)
 funArgTy (NewTcApp tc tys) = funArgTy (newTypeRep tc tys)
-funArgTy ty		   = pprPanic "funArgTy" (crudePprType ty)
+funArgTy ty		   = pprPanic "funArgTy" (ppr ty)
 \end{code}
 
 
@@ -352,7 +355,7 @@ tyConAppArgs ty = snd (splitTyConApp ty)
 splitTyConApp :: Type -> (TyCon, [Type])
 splitTyConApp ty = case splitTyConApp_maybe ty of
 			Just stuff -> stuff
-			Nothing	   -> pprPanic "splitTyConApp" (crudePprType ty)
+			Nothing	   -> pprPanic "splitTyConApp" (ppr ty)
 
 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
@@ -436,7 +439,7 @@ typePrimRep ty = case repType ty of
 		   FunTy _ _	 -> PtrRep
 		   AppTy _ _	 -> PtrRep	-- ??
 		   TyVarTy _	 -> PtrRep
-		   other	 -> pprPanic "typePrimRep" (crudePprType ty)
+		   other	 -> pprPanic "typePrimRep" (ppr ty)
 \end{code}
 
 
@@ -518,7 +521,7 @@ applyTys orig_fun_ty arg_tys
   = substTyWith (take n_args tvs) arg_tys 
 		(mkForAllTys (drop n_args tvs) rho_ty)
   | otherwise		-- Too many type args
-  = ASSERT2( n_tvs > 0, crudePprType orig_fun_ty )	-- Zero case gives infnite loop!
+  = ASSERT2( n_tvs > 0, ppr orig_fun_ty )	-- Zero case gives infnite loop!
     applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty)
 	     (drop n_tvs arg_tys)
   where
@@ -555,11 +558,6 @@ predTypeRep (IParam _ ty)     = ty
 predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
 	-- Result might be a NewTcApp, but the consumer will
 	-- look through that too if necessary
-
-isPredTy :: Type -> Bool
-isPredTy (NoteTy _ ty) = isPredTy ty
-isPredTy (PredTy sty)  = True
-isPredTy _	       = False
 \end{code}