[project @ 2003-12-10 14:15:16 by simonmar]

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

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 333b589..20dbb00 100644 (file)
--- 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}