[project @ 2001-08-14 06:35:56 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcType.lhs

diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index d9c6387..a6abdcf 100644 (file)
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -52,7 +52,7 @@ module TcType (
   PredType, mkPredTy, mkPredTys, getClassPredTys_maybe, getClassPredTys, 
   isPredTy, isClassPred, isTyVarClassPred, predHasFDs,
   mkDictTy, tcSplitPredTy_maybe, predTyUnique,
-  isDictTy, tcSplitDFunTy,
+  isDictTy, tcSplitDFunTy, predTyUnique, 
   mkClassPred, predMentionsIPs, inheritablePred, isIPPred, mkPredName,
 
   ---------------------------------
@@ -63,20 +63,24 @@ module TcType (
 
   --------------------------------
   -- Rexported from Type
-  Kind, Type, SourceType(..), PredType, ThetaType, 
-  unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
+  Kind,        -- Stuff to do with kinds is insensitive to pre/post Tc
+  unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, 
+  superBoxity, liftedBoxity, hasMoreBoxityInfo, defaultKind, superKind,
+  isTypeKind,
+
+  Type, SourceType(..), PredType, ThetaType, 
   mkForAllTy, mkForAllTys, 
   mkFunTy, mkFunTys, zipFunTys, 
   mkTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
-  mkTyVarTy, mkTyVarTys, mkTyConTy,
-  predTyUnique, mkClassPred, 
+  mkTyVarTy, mkTyVarTys, mkTyConTy, 
+
   isUnLiftedType,      -- Source types are always lifted
   isUnboxedTupleType,  -- Ditto
+
   tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
   tidyTyVar, tidyTyVars,
-  eqKind, eqUsage,
+  typeKind, eqKind, eqUsage,
 
-  -- Reexported ???
   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta
   ) where
 
@@ -86,8 +90,22 @@ module TcType (
 import {-# SOURCE #-} PprType( pprType )
 
 -- friends:
-import TypeRep         ( Type(..), TyNote(..) )  -- friend
-import Type            -- Lots and lots
+import TypeRep         ( Type(..), TyNote(..), funTyCon )  -- friend
+import Type            ( mkUTyM, unUTy )       -- Used locally
+
+import Type            (       -- Re-exports
+                         tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
+                         Kind, Type, TauType, SourceType(..), PredType, ThetaType, 
+                         unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
+                         mkForAllTy, mkForAllTys, defaultKind, isTypeKind,
+                         mkFunTy, mkFunTys, zipFunTys, 
+                         mkTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
+                         mkTyVarTy, mkTyVarTys, mkTyConTy,
+                         isUnLiftedType, isUnboxedTupleType,
+                         tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
+                         tidyTyVar, tidyTyVars, eqKind, eqUsage,
+                         hasMoreBoxityInfo, liftedBoxity, superBoxity, typeKind, superKind
+                       )
 import TyCon           ( TyCon, isPrimTyCon, tyConArity, isNewTyCon )
 import Class           ( classTyCon, classHasFDs, Class )
 import Var             ( TyVar, tyVarKind )
@@ -137,7 +155,7 @@ isTauTy (TyVarTy v)  = True
 isTauTy (TyConApp _ tys) = all isTauTy tys
 isTauTy (AppTy a b)     = isTauTy a && isTauTy b
 isTauTy (FunTy a b)     = isTauTy a && isTauTy b
-isTauTy (SourceTy p)    = isTauTy (sourceTypeRep p)
+isTauTy (SourceTy p)    = True         -- Don't look through source types
 isTauTy (NoteTy _ ty)   = isTauTy ty
 isTauTy (UsageTy _ ty)   = isTauTy ty
 isTauTy other           = False
@@ -327,7 +345,7 @@ tcSplitPredTy_maybe (NoteTy _ ty)       = tcSplitPredTy_maybe ty
 tcSplitPredTy_maybe (UsageTy _ ty)         = tcSplitPredTy_maybe ty
 tcSplitPredTy_maybe (SourceTy p) | isPred p = Just p
 tcSplitPredTy_maybe other                  = Nothing
-
+       
 mkPredTy :: PredType -> Type
 mkPredTy pred = SourceTy pred
 
@@ -360,7 +378,7 @@ isClassPred :: SourceType -> Bool
 isClassPred (ClassP clas tys) = True
 isClassPred other            = False
 
-isTyVarClassPred (ClassP clas tys) = all isTyVarTy tys
+isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys
 isTyVarClassPred other            = False
 
 getClassPredTys_maybe :: SourceType -> Maybe (Class, [Type])
@@ -548,7 +566,7 @@ isPrimitiveType :: Type -> Bool
 -- Returns types that are opaque to Haskell.
 -- Most of these are unlifted, but now that we interact with .NET, we
 -- may have primtive (foreign-imported) types that are lifted
-isPrimitiveType ty = case splitTyConApp_maybe ty of
+isPrimitiveType ty = case tcSplitTyConApp_maybe ty of
                        Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
                                              isPrimTyCon tc
                        other              -> False
@@ -735,6 +753,14 @@ uTysX ty1 (TyVarTy tyvar2) k subst@(tmpls,_)
   | tyvar2 `elemVarSet` tmpls
   = uVarX tyvar2 ty1 k subst
 
+       -- Predicates
+uTysX (SourceTy (IParam n1 t1)) (SourceTy (IParam n2 t2)) k subst
+  | n1 == n2 = uTysX t1 t2 k subst
+uTysX (SourceTy (ClassP c1 tys1)) (SourceTy (ClassP c2 tys2)) k subst
+  | c1 == c2 = uTyListsX tys1 tys2 k subst
+uTysX (SourceTy (NType tc1 tys1)) (SourceTy (NType tc2 tys2)) k subst
+  | tc1 == tc2 = uTyListsX tys1 tys2 k subst
+
        -- Functions; just check the two parts
 uTysX (FunTy fun1 arg1) (FunTy fun2 arg2) k subst
   = uTysX fun1 fun2 (uTysX arg1 arg2 k) subst
@@ -874,6 +900,15 @@ match (TyVarTy v) ty tmpls k senv
     -- variable may not match the pattern (TyVarTy v') as one would
     -- expect, due to an intervening Note.  KSW 2000-06.
 
+       -- Predicates
+match (SourceTy (IParam n1 t1)) (SourceTy (IParam n2 t2)) tmpls k senv
+  | n1 == n2 = match t1 t2 tmpls k senv
+match (SourceTy (ClassP c1 tys1)) (SourceTy (ClassP c2 tys2)) tmpls k senv
+  | c1 == c2 = match_list_exactly tys1 tys2 tmpls k senv
+match (SourceTy (NType tc1 tys1)) (SourceTy (NType tc2 tys2)) tmpls k senv
+  | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv
+
+       -- Functions; just check the two parts
 match (FunTy arg1 res1) (FunTy arg2 res2) tmpls k senv
   = match arg1 arg2 tmpls (match res1 res2 tmpls k) senv
 
@@ -883,11 +918,11 @@ match (AppTy fun1 arg1) ty2 tmpls k senv
        Nothing          -> Nothing     -- Fail
 
 match (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv
-  | tc1 == tc2 = match_tc_app tys1 tys2 tmpls k senv
+  | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv
 
 -- Newtypes are opaque; other source types should not happen
 match (SourceTy (NType tc1 tys1)) (SourceTy (NType tc2 tys2)) tmpls k senv
-  | tc1 == tc2 = match_tc_app tys1 tys2 tmpls k senv
+  | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv
 
 match (UsageTy _ ty1) ty2 tmpls k senv = match ty1 ty2 tmpls k senv
 match ty1 (UsageTy _ ty2) tmpls k senv = match ty1 ty2 tmpls k senv
@@ -902,7 +937,7 @@ match ty1      (NoteTy n2 ty2) tmpls k senv = match ty1 ty2 tmpls k senv
 -- Catch-all fails
 match _ _ _ _ _ = Nothing
 
-match_tc_app tys1 tys2 tmpls k senv
+match_list_exactly tys1 tys2 tmpls k senv
   = match_list tys1 tys2 tmpls k' senv
   where
     k' (senv', tys2') | null tys2' = k senv'   -- Succeed