[project @ 1996-04-05 08:26:04 by partain]

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

diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 1008e0c..530e41a 100644 (file)
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -18,12 +18,10 @@ module TcType (
   tcReadTyVar,         -- :: TcTyVar s -> NF_TcM (TcMaybe s)
 
 
-  tcInstTyVar,    -- TyVar -> NF_TcM s (TcTyVar s)
+  tcInstTyVars,    -- TyVar -> NF_TcM s (TcTyVar s)
+  tcInstSigTyVars, 
   tcInstType, tcInstTcType, tcInstTheta,
 
---  zonkTcType,                -- TcType s     -> NF_TcM s (TcType s)
---  zonkTcTheta,       -- TcThetaType s -> NF_TcM s (TcThetaType s)
-
     zonkTcTyVars,      -- TcTyVarSet s -> NF_TcM s (TcTyVarSet s)
     zonkTcType,                -- TcType s -> NF_TcM s (TcType s)
     zonkTcTypeToType,  -- TcType s -> NF_TcM s Type
@@ -51,7 +49,12 @@ import Unique                ( Unique )
 import UniqFM          ( UniqFM )
 import Name            ( getNameShortName )
 import Maybes          ( assocMaybe )
-import Util            ( panic )
+import Util            ( panic, pprPanic )
+
+import Outputable      ( Outputable(..) )      -- Debugging messages
+import PprType         ( GenTyVar, GenType )
+import Pretty                                  -- ditto
+import PprStyle                ( PprStyle(..) )        -- ditto
 \end{code}
 
 
@@ -74,6 +77,12 @@ type Box s = MutableVar s (TcMaybe s)
 
 data TcMaybe s = UnBound
               | BoundTo (TcType s)
+              | DontBind               -- This variant is used for tyvars
+                                       -- arising from type signatures, or
+                                       -- existentially quantified tyvars;
+                                       -- The idea is that we must not unify
+                                       -- such tyvars with anything except
+                                       -- themselves.
 
 -- Interestingly, you can't use (Maybe (TcType s)) instead of (TcMaybe s),
 -- because you get a synonym loop if you do!
@@ -91,23 +100,41 @@ Type instantiation
 ~~~~~~~~~~~~~~~~~~
 
 \begin{code}
-newTcTyVar :: Maybe ShortName -> Kind -> NF_TcM s (TcTyVar s)
-newTcTyVar name kind
+newTcTyVar :: Kind -> NF_TcM s (TcTyVar s)
+newTcTyVar kind
   = tcGetUnique        `thenNF_Tc` \ uniq ->
     tcNewMutVar UnBound        `thenNF_Tc` \ box ->
-    returnNF_Tc (TyVar uniq kind name box)
+    returnNF_Tc (TyVar uniq kind Nothing box)
 
 newTyVarTy  :: Kind -> NF_TcM s (TcType s)
 newTyVarTy kind
-  = newTcTyVar Nothing kind    `thenNF_Tc` \ tc_tyvar ->
+  = newTcTyVar kind    `thenNF_Tc` \ tc_tyvar ->
     returnNF_Tc (TyVarTy tc_tyvar)
 
 newTyVarTys :: Int -> Kind -> NF_TcM s [TcType s]
 newTyVarTys n kind = mapNF_Tc newTyVarTy (take n (repeat kind))
 
-tcInstTyVar :: TyVar -> NF_TcM s (TcTyVar s)
-tcInstTyVar tyvar@(TyVar uniq kind name _)
-  = newTcTyVar name kind
+
+
+-- For signature type variables, mark them as "DontBind"
+tcInstTyVars, tcInstSigTyVars
+       :: [GenTyVar flexi] 
+       -> NF_TcM s ([TcTyVar s], [TcType s], [(GenTyVar flexi, TcType s)])
+tcInstTyVars    tyvars = inst_tyvars UnBound  tyvars
+tcInstSigTyVars tyvars = inst_tyvars DontBind tyvars
+
+
+inst_tyvars initial_cts tyvars
+  = mapNF_Tc (inst_tyvar initial_cts) tyvars   `thenNF_Tc` \ tc_tyvars ->
+    let
+       tys = map TyVarTy tc_tyvars
+    in
+    returnNF_Tc (tc_tyvars, tys, tyvars `zip` tys)
+
+inst_tyvar initial_cts (TyVar _ kind name _) 
+  = tcGetUnique                `thenNF_Tc` \ uniq ->
+    tcNewMutVar initial_cts    `thenNF_Tc` \ box ->
+    returnNF_Tc (TyVar uniq kind name box)
 \end{code}
 
 @tcInstType@ and @tcInstTcType@ both create a fresh instance of a
@@ -143,13 +170,14 @@ tcInstType tenv ty_to_inst
     do env (DictTy clas ty usage)= do env ty           `thenNF_Tc` \ ty' ->
                                   returnNF_Tc (DictTy clas ty' usage)
 
-    do env (TyVarTy (TyVar uniq kind name _))
+    do env (TyVarTy tv@(TyVar uniq kind name _))
        = case assocMaybe env uniq of
                Just tc_ty -> returnNF_Tc tc_ty
-               Nothing    -> panic "tcInstType"
+               Nothing    -> pprPanic "tcInstType:" (ppAboves [ppr PprDebug tenv, 
+                                             ppr PprDebug ty_to_inst, ppr PprDebug tv])
 
-    do env (ForAllTy (TyVar uniq kind name _) ty)
-       = newTcTyVar name kind  `thenNF_Tc` \ tc_tyvar ->
+    do env (ForAllTy tyvar@(TyVar uniq kind name _) ty)
+       = inst_tyvar DontBind tyvar     `thenNF_Tc` \ tc_tyvar ->
          let
                new_env = (uniq, TyVarTy tc_tyvar) : env
          in
@@ -166,6 +194,8 @@ tcInstTheta tenv theta
     go (clas,ty) = tcInstType tenv ty  `thenNF_Tc` \ tc_ty ->
                   returnNF_Tc (clas, tc_ty)
 
+--???tcSpecTy :: Type -> NF_TcM s (
+
 tcInstTcType ::  [(TcTyVar s,TcType s)] -> TcType s -> NF_TcM s (TcType s)
 tcInstTcType tenv ty_to_inst
   = do [(uniq,ty) | (TyVar uniq _ _ _, ty) <- tenv] ty_to_inst
@@ -193,15 +223,10 @@ tcInstTcType tenv ty_to_inst
                Just tc_ty -> returnNF_Tc tc_ty
                Nothing    -> returnNF_Tc ty
 
-    do env (ForAllTy (TyVar uniq kind name _) ty)
-       = newTcTyVar name kind  `thenNF_Tc` \ tc_tyvar ->
-         let
-               new_env = (uniq, TyVarTy tc_tyvar) : env
-         in
-         do new_env ty `thenNF_Tc` \ ty' ->
-         returnNF_Tc (ForAllTy tc_tyvar ty')
+    do env (ForAllTy (TyVar uniq kind name _) ty) = panic "tcInstTcType"
 
    -- ForAllUsage impossible
+
 \end{code}
 
 Reading and writing TcTyVars
@@ -232,20 +257,22 @@ We return Nothing iff the original box was unbound.
 tcReadTyVar (TyVar uniq kind name box)
   = tcReadMutVar box   `thenNF_Tc` \ maybe_ty ->
     case maybe_ty of
-       UnBound    -> returnNF_Tc UnBound
        BoundTo ty -> short_out ty                      `thenNF_Tc` \ ty' ->
                      tcWriteMutVar box (BoundTo ty')   `thenNF_Tc_`
                      returnNF_Tc (BoundTo ty')
 
+       other      -> returnNF_Tc other
+
 short_out :: TcType s -> NF_TcM s (TcType s)
 short_out ty@(TyVarTy (TyVar uniq kind name box))
   = tcReadMutVar box   `thenNF_Tc` \ maybe_ty ->
     case maybe_ty of
-       UnBound     -> returnNF_Tc ty
        BoundTo ty' -> short_out ty'                    `thenNF_Tc` \ ty' ->
                       tcWriteMutVar box (BoundTo ty')  `thenNF_Tc_`
                       returnNF_Tc ty'
 
+       other       -> returnNF_Tc ty
+
 short_out other_ty = returnNF_Tc other_ty
 \end{code}
 
@@ -310,8 +337,8 @@ zonk tyvar_fn (DictTy c ty u)
 zonk_tv tyvar_fn tyvar
   = tcReadTyVar tyvar          `thenNF_Tc` \ maybe_ty ->
     case maybe_ty of
-       UnBound    -> returnNF_Tc (TyVarTy (tyvar_fn tyvar))
        BoundTo ty -> zonk tyvar_fn ty
+       other      -> returnNF_Tc (TyVarTy (tyvar_fn tyvar))
 
 
 zonk_tv_to_tv tyvar_fn tyvar