[project @ 1999-05-11 16:37:29 by keithw]

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

diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 038789b..48d58fe 100644 (file)
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -26,6 +26,7 @@ module TcType (
   tcSplitRhoTy,
 
   tcInstTyVars,
+  tcInstSigVar,
   tcInstTcType,
 
   typeToTcType,
@@ -53,12 +54,13 @@ module TcType (
 import PprType         ( pprType )
 import Type            ( Type(..), Kind, ThetaType, TyNote(..), 
                          mkAppTy, mkTyConApp,
-                         splitDictTy_maybe, splitForAllTys,
+                         splitDictTy_maybe, splitForAllTys, isNotUsgTy,
                          isTyVarTy, mkTyVarTy, mkTyVarTys, 
                          fullSubstTy, substTopTy, 
                          typeCon, openTypeKind, boxedTypeKind, boxedKind, superKind, superBoxity
                        )
-import TyCon           ( tyConKind )
+import TyCon           ( tyConKind, mkPrimTyCon )
+import PrimRep         ( PrimRep(VoidRep) )
 import VarEnv
 import VarSet          ( emptyVarSet )
 import Var             ( TyVar, tyVarKind, tyVarName, isTyVar, isMutTyVar, mkTyVar )
@@ -67,8 +69,10 @@ import Var           ( TyVar, tyVarKind, tyVarName, isTyVar, isMutTyVar, mkTyVar )
 import TcMonad
 import TysWiredIn      ( voidTy )
 
-import Name            ( NamedThing(..), setNameUnique, mkSysLocalName )
-import Unique          ( Unique )
+import Name            ( NamedThing(..), setNameUnique, mkSysLocalName,
+                         mkDerivedName, mkDerivedTyConOcc
+                       )
+import Unique          ( Unique, Uniquable(..) )
 import Util            ( nOfThem )
 import Outputable
 \end{code}
@@ -169,16 +173,15 @@ tcInstTyVars :: [TyVar]
             -> NF_TcM s ([TcTyVar], [TcType], TyVarEnv TcType)
 
 tcInstTyVars tyvars
-  = mapNF_Tc inst_tyvar tyvars `thenNF_Tc` \ tc_tyvars ->
+  = mapNF_Tc tcInstTyVar tyvars        `thenNF_Tc` \ tc_tyvars ->
     let
        tys = mkTyVarTys tc_tyvars
     in
     returnNF_Tc (tc_tyvars, tys, zipVarEnv tyvars tys)
 
-inst_tyvar tyvar       -- Could use the name from the tyvar?
+tcInstTyVar tyvar
   = tcGetUnique                `thenNF_Tc` \ uniq ->
     let
-       kind = tyVarKind tyvar
        name = setNameUnique (tyVarName tyvar) uniq
        -- Note that we don't change the print-name
        -- This won't confuse the type checker but there's a chance
@@ -186,8 +189,35 @@ inst_tyvar tyvar   -- Could use the name from the tyvar?
        -- in an error message.  -dppr-debug will show up the difference
        -- Better watch out for this.  If worst comes to worst, just
        -- use mkSysLocalName.
+
+       kind = tyVarKind tyvar
     in
-    tcNewMutTyVar name kind
+
+       -- Hack alert!  Certain system functions (like error) are quantified
+       -- over type variables with an 'open' kind (a :: ?).  When we instantiate
+       -- these tyvars we want to make a type variable whose kind is (Type bv)
+       -- where bv is a boxity variable.  This makes sure it's a type, but 
+       -- is open about its boxity.  We *don't* want to give the thing the
+       -- kind '?' (= Type AnyBox).  
+       --
+       -- This is all a hack to avoid giving error it's "proper" type:
+       --       error :: forall bv. forall a::Type bv. String -> a
+
+    (if kind == openTypeKind then
+       newOpenTypeKind 
+     else
+       returnNF_Tc kind)       `thenNF_Tc` \ kind' ->
+
+    tcNewMutTyVar name kind'
+
+tcInstSigVar tyvar     -- Very similar to tcInstTyVar
+  = tcGetUnique        `thenNF_Tc` \ uniq ->
+    let 
+       name = setNameUnique (tyVarName tyvar) uniq
+       kind = tyVarKind tyvar
+    in
+    ASSERT( not (kind == openTypeKind) )       -- Shouldn't happen
+    tcNewSigTyVar name kind
 \end{code}
 
 @tcInstTcType@ instantiates the outer-level for-alls of a TcType with
@@ -333,18 +363,17 @@ zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty
     zonk_unbound_tyvar tv
        = zonkTcKindToKind (tyVarKind tv)       `thenNF_Tc` \ kind ->
          if kind == boxedTypeKind then
-               tcPutTyVar tv voidTy    -- Just to creating a new tycon in
+               tcPutTyVar tv voidTy    -- Just to avoid creating a new tycon in
                                        -- this vastly common case
          else
-               tcPutTyVar tv (TyConApp (mk_void_tycon tv) [])
-
-    mk_void_tycon tv   -- Make a new TyCon with the same kind as the 
-                       -- type variable tv.  Same name too, apart from
-                       -- making it start with a capital letter (sigh)
-                       -- I can't quite bring myself to write the Name-fiddling
-                       -- code yet.  ToDo.  SLPJ Nov 98
-       = pprPanic "zonkTcTypeToType: free type variable with non-* type:" (ppr tv)
+               tcPutTyVar tv (TyConApp (mk_void_tycon tv kind) [])
 
+    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
+       where
+         tc_name = mkDerivedName mkDerivedTyConOcc (getName tv) (getUnique tv)
 
 -- zonkTcTyVarToTyVar is applied to the *binding* occurrence 
 -- of a type variable, at the *end* of type checking.
@@ -404,6 +433,9 @@ 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 (FunTy arg res)           = go arg              `thenNF_Tc` \ arg' ->
                                    go res              `thenNF_Tc` \ res' ->
                                    returnNF_Tc (FunTy arg' res')
@@ -434,7 +466,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}
 
 %************************************************************************