[project @ 2000-07-11 16:24:57 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index ff0a61e..81b4ee8 100644 (file)
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -40,7 +40,7 @@ module TcType (
 
   --------------------------------
   zonkTcTyVar, zonkTcTyVars, zonkTcTyVarBndr,
-  zonkTcType, zonkTcTypes, zonkTcThetaType,
+  zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType,
 
   zonkTcTypeToType, zonkTcTyVarToTyVar,
   zonkTcKindToKind
@@ -51,18 +51,17 @@ module TcType (
 
 
 -- friends:
-import PprType         ( pprType )
-import Type            ( Type(..), Kind, ThetaType, TyNote(..), 
+import TypeRep         ( Type(..), Kind, TyNote(..), 
+                         typeCon, openTypeKind, boxedTypeKind, boxedKind, superKind, superBoxity
+                       )  -- friend
+import Type            ( ThetaType, PredType(..),
                          mkAppTy, mkTyConApp,
-                         splitDictTy_maybe, splitForAllTys,
+                         splitPredTy_maybe, splitForAllTys, isNotUsgTy,
                          isTyVarTy, mkTyVarTy, mkTyVarTys, 
-                         fullSubstTy, substTopTy, 
-                         typeCon, openTypeKind, boxedTypeKind, boxedKind, superKind, superBoxity
                        )
+import Subst           ( Subst, mkTopTyVarSubst, substTy )
 import TyCon           ( tyConKind, mkPrimTyCon )
 import PrimRep         ( PrimRep(VoidRep) )
-import VarEnv
-import VarSet          ( emptyVarSet )
 import Var             ( TyVar, tyVarKind, tyVarName, isTyVar, isMutTyVar, mkTyVar )
 
 -- others:
@@ -106,7 +105,7 @@ tcSplitRhoTy t
  where
        -- A type variable is never instantiated to a dictionary type,
        -- so we don't need to do a tcReadVar on the "arg".
-    go syn_t (FunTy arg res) ts = case splitDictTy_maybe arg of
+    go syn_t (FunTy arg res) ts = case splitPredTy_maybe arg of
                                        Just pair -> go res res (pair:ts)
                                        Nothing   -> returnNF_Tc (reverse ts, syn_t)
     go syn_t (NoteTy _ t)    ts = go syn_t t ts
@@ -170,14 +169,17 @@ Instantiating a bunch of type variables
 
 \begin{code}
 tcInstTyVars :: [TyVar] 
-            -> NF_TcM s ([TcTyVar], [TcType], TyVarEnv TcType)
+            -> NF_TcM s ([TcTyVar], [TcType], Subst)
 
 tcInstTyVars tyvars
   = mapNF_Tc tcInstTyVar tyvars        `thenNF_Tc` \ tc_tyvars ->
     let
        tys = mkTyVarTys tc_tyvars
     in
-    returnNF_Tc (tc_tyvars, tys, zipVarEnv tyvars tys)
+    returnNF_Tc (tc_tyvars, tys, mkTopTyVarSubst tyvars tys)
+               -- Since the tyvars are freshly made,
+               -- they cannot possibly be captured by
+               -- any existing for-alls.  Hence mkTopTyVarSubst
 
 tcInstTyVar tyvar
   = tcGetUnique                `thenNF_Tc` \ uniq ->
@@ -229,10 +231,7 @@ tcInstTcType ty
   = case splitForAllTys ty of
        ([], _)       -> returnNF_Tc ([], ty)   -- Nothing to do
        (tyvars, rho) -> tcInstTyVars tyvars            `thenNF_Tc` \ (tyvars', _, tenv)  ->
-                        returnNF_Tc (tyvars', fullSubstTy tenv emptyVarSet rho)
-                                       -- Since the tyvars are freshly made,
-                                       -- they cannot possibly be captured by
-                                       -- any existing for-alls.  Hence emptyVarSet
+                        returnNF_Tc (tyvars', substTy tenv rho)
 \end{code}
 
 
@@ -310,8 +309,11 @@ zonkTcTyVars tyvars = mapNF_Tc zonkTcTyVar tyvars
 
 zonkTcTyVarBndr :: TcTyVar -> NF_TcM s TcTyVar
 zonkTcTyVarBndr tyvar
-  = zonkTcTyVar tyvar  `thenNF_Tc` \ (TyVarTy tyvar') ->
-    returnNF_Tc tyvar'
+  = zonkTcTyVar tyvar  `thenNF_Tc` \ ty ->
+    case ty of
+       TyVarTy tyvar' -> returnNF_Tc tyvar'
+       _              -> pprTrace "zonkTcTyVarBndr" (ppr tyvar <+> ppr ty) $
+                         returnNF_Tc tyvar
        
 zonkTcTyVar :: TcTyVar -> NF_TcM s TcType
 zonkTcTyVar tyvar = zonkTyVar (\ tv -> returnNF_Tc (TyVarTy tv)) tyvar
@@ -326,11 +328,21 @@ zonkTcType ty = zonkType (\ tv -> returnNF_Tc (TyVarTy tv)) ty
 zonkTcTypes :: [TcType] -> NF_TcM s [TcType]
 zonkTcTypes tys = mapNF_Tc zonkTcType tys
 
+zonkTcClassConstraints cts = mapNF_Tc zonk cts
+    where zonk (clas, tys)
+           = zonkTcTypes tys   `thenNF_Tc` \ new_tys ->
+             returnNF_Tc (clas, new_tys)
+
 zonkTcThetaType :: TcThetaType -> NF_TcM s TcThetaType
-zonkTcThetaType theta = mapNF_Tc zonk theta
-                   where
-                       zonk (c,ts) = zonkTcTypes ts    `thenNF_Tc` \ new_ts ->
-                                     returnNF_Tc (c, new_ts)
+zonkTcThetaType theta = mapNF_Tc zonkTcPredType theta
+
+zonkTcPredType :: TcPredType -> NF_TcM s TcPredType
+zonkTcPredType (Class c ts) =
+    zonkTcTypes ts     `thenNF_Tc` \ new_ts ->
+    returnNF_Tc (Class c new_ts)
+zonkTcPredType (IParam n t) =
+    zonkTcType t       `thenNF_Tc` \ new_t ->
+    returnNF_Tc (IParam n new_t)
 
 zonkTcKind :: TcKind -> NF_TcM s TcKind
 zonkTcKind = zonkTcType
@@ -371,7 +383,7 @@ zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty
     mk_void_tycon tv kind      -- Make a new TyCon with the same kind as the 
                                -- type variable tv.  Same name too, apart from
                                -- making it start with a colon (sigh)
-       = mkPrimTyCon tc_name kind 0 VoidRep
+       = mkPrimTyCon tc_name kind 0 [] VoidRep
        where
          tc_name = mkDerivedName mkDerivedTyConOcc (getName tv) (getUnique tv)
 
@@ -433,6 +445,15 @@ zonkType unbound_var_fn ty
 
     go (NoteTy (FTVNote _) ty2)   = go ty2     -- Discard free-tyvar annotations
 
+    go (NoteTy (UsgNote usg) ty2) = go ty2             `thenNF_Tc` \ ty2' ->
+                                   returnNF_Tc (NoteTy (UsgNote usg) ty2')
+
+    go (NoteTy (UsgForAll uv) ty2)= go ty2             `thenNF_Tc` \ ty2' ->
+                                   returnNF_Tc (NoteTy (UsgForAll uv) ty2')
+
+    go (NoteTy (IPNote nm) ty2)   = go ty2             `thenNF_Tc` \ ty2' ->
+                                   returnNF_Tc (NoteTy (IPNote nm) ty2')
+
     go (FunTy arg res)           = go arg              `thenNF_Tc` \ arg' ->
                                    go res              `thenNF_Tc` \ res' ->
                                    returnNF_Tc (FunTy arg' res')
@@ -463,7 +484,8 @@ zonkTyVar unbound_var_fn tyvar
   =  tcGetTyVar tyvar  `thenNF_Tc` \ maybe_ty ->
      case maybe_ty of
          Nothing       -> unbound_var_fn tyvar                 -- Mutable and unbound
-         Just other_ty -> zonkType unbound_var_fn other_ty     -- Bound
+         Just other_ty -> ASSERT( isNotUsgTy other_ty )
+                           zonkType unbound_var_fn other_ty    -- Bound
 \end{code}
 
 %************************************************************************