[project @ 2001-01-03 11:18:51 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 58aac30..6e8fc04 100644 (file)
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -44,12 +44,12 @@ module TcType (
 -- friends:
 import TypeRep         ( Type(..), Kind, TyNote(..) )  -- friend
 import Type            ( PredType(..),
-                         getTyVar, mkAppTy,
-                         splitPredTy_maybe, splitForAllTys, isNotUsgTy,
+                         getTyVar, mkAppTy, mkUTy,
+                         splitPredTy_maybe, splitForAllTys, 
                          isTyVarTy, mkTyVarTy, mkTyVarTys, 
-                         openTypeKind, boxedTypeKind, 
+                         openTypeKind, liftedTypeKind, 
                          superKind, superBoxity, 
-                         defaultKind, boxedBoxity
+                         defaultKind, liftedBoxity
                        )
 import Subst           ( Subst, mkTopTyVarSubst, substTy )
 import TyCon           ( mkPrimTyCon )
@@ -61,9 +61,10 @@ import TcMonad          -- TcType, amongst others
 import TysWiredIn      ( voidTy )
 
 import Name            ( Name, NamedThing(..), setNameUnique, mkSysLocalName,
-                         mkDerivedName, mkDerivedTyConOcc
+                         mkLocalName, mkDerivedTyConOcc
                        )
 import Unique          ( Uniquable(..) )
+import SrcLoc          ( noSrcLoc )
 import Util            ( nOfThem )
 import Outputable
 \end{code}
@@ -92,6 +93,7 @@ tcSplitRhoTy t
                                  case maybe_ty of
                                    Just ty | not (isTyVarTy ty) -> go syn_t ty ts
                                    other                        -> returnNF_Tc (reverse ts, syn_t)
+    go syn_t (UsageTy _ t)   ts = go syn_t t ts
     go syn_t t              ts = returnNF_Tc (reverse ts, syn_t)
 \end{code}
 
@@ -206,7 +208,8 @@ tcGetTyVar :: TcTyVar -> NF_TcM (Maybe TcType)
 Putting is easy:
 
 \begin{code}
-tcPutTyVar tyvar ty = tcWriteMutTyVar tyvar (Just ty)  `thenNF_Tc_`
+tcPutTyVar tyvar ty = UASSERT2( not (isUTy ty), ppr tyvar <+> ppr ty )
+                      tcWriteMutTyVar tyvar (Just ty)  `thenNF_Tc_`
                      returnNF_Tc ty
 \end{code}
 
@@ -315,18 +318,18 @@ zonkKindEnv pairs
        -- When zonking a kind, we want to
        --      zonk a *kind* variable to (Type *)
        --      zonk a *boxity* variable to *
-    zonk_unbound_kind_var kv | tyVarKind kv == superKind   = tcPutTyVar kv boxedTypeKind
-                            | tyVarKind kv == superBoxity = tcPutTyVar kv boxedBoxity
+    zonk_unbound_kind_var kv | tyVarKind kv == superKind   = tcPutTyVar kv liftedTypeKind
+                            | tyVarKind kv == superBoxity = tcPutTyVar kv liftedBoxity
                             | otherwise                   = pprPanic "zonkKindEnv" (ppr kv)
                        
 zonkTcTypeToType :: TcType -> NF_TcM Type
 zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty
   where
        -- Zonk a mutable but unbound type variable to
-       --      Void            if it has kind Boxed
+       --      Void            if it has kind Lifted
        --      :Void           otherwise
     zonk_unbound_tyvar tv
-       | kind == boxedTypeKind
+       | kind == liftedTypeKind
        = tcPutTyVar tv voidTy  -- Just to avoid creating a new tycon in
                                -- this vastly common case
        | otherwise
@@ -337,9 +340,12 @@ 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
+               -- I dread to think what will happen if this gets out into an 
+               -- interface file.  Catastrophe likely.  Major sigh.
+       = pprTrace "Urk! Inventing strangely-kinded void TyCon" (ppr tc_name) $
+         mkPrimTyCon tc_name kind 0 [] VoidRep
        where
-         tc_name = mkDerivedName mkDerivedTyConOcc (getName tv) (getUnique tv)
+         tc_name = mkLocalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
 
 -- zonkTcTyVarToTyVar is applied to the *binding* occurrence 
 -- of a type variable, at the *end* of type checking.  It changes
@@ -353,7 +359,7 @@ zonkTcTyVarToTyVar :: TcTyVar -> NF_TcM TyVar
 zonkTcTyVarToTyVar tv
   = let
                -- Make an immutable version, defaulting 
-               -- the kind to boxed if necessary
+               -- the kind to lifted if necessary
        immut_tv    = mkTyVar (tyVarName tv) (defaultKind (tyVarKind tv))
        immut_tv_ty = mkTyVarTy immut_tv
 
@@ -401,12 +407,6 @@ 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 (PredTy p)                = go_pred p           `thenNF_Tc` \ p' ->
                                    returnNF_Tc (PredTy p')
 
@@ -418,6 +418,10 @@ zonkType unbound_var_fn ty
                                    go arg              `thenNF_Tc` \ arg' ->
                                    returnNF_Tc (mkAppTy fun' arg')
 
+    go (UsageTy u ty)             = go u                `thenNF_Tc` \ u'  ->
+                                    go ty               `thenNF_Tc` \ ty' ->
+                                    returnNF_Tc (mkUTy u' ty')
+
        -- The two interesting cases!
     go (TyVarTy tyvar)     = zonkTyVar unbound_var_fn tyvar
 
@@ -443,7 +447,6 @@ 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 -> ASSERT( isNotUsgTy other_ty )
-                           zonkType unbound_var_fn other_ty    -- Bound
+         Just other_ty -> zonkType unbound_var_fn other_ty     -- Bound
 \end{code}