[project @ 2003-06-24 07:58:18 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index 9947d82..207411c 100644 (file)
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -11,15 +11,13 @@ module TcMType (
 
   --------------------------------
   -- Creating new mutable type variables
-  newTyVar, 
+  newTyVar, newSigTyVar,
   newTyVarTy,          -- Kind -> TcM TcType
   newTyVarTys,         -- Int -> Kind -> TcM [TcType]
   newKindVar, newKindVars, newOpenTypeKind,
   putTcTyVar, getTcTyVar,
   newMutTyVar, readMutTyVar, writeMutTyVar, 
 
-  newHoleTyVarTy, readHoleResult, zapToType,
-
   --------------------------------
   -- Instantiation
   tcInstTyVar, tcInstTyVars, tcInstType, 
@@ -54,7 +52,7 @@ import TcType         ( TcType, TcThetaType, TcTauType, TcPredType,
                          tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, 
                          tcSplitTyConApp_maybe, tcSplitForAllTys,
                          tcIsTyVarTy, tcSplitSigmaTy, mkTyConApp,
-                         isUnLiftedType, isIPPred, isHoleTyVar, isTyVarTy,
+                         isUnLiftedType, isIPPred, isTyVarTy,
 
                          mkAppTy, mkTyVarTy, mkTyVarTys, 
                          tyVarsOfPred, getClassPredTys_maybe,
@@ -85,7 +83,7 @@ import PprType                ( pprPred, pprSourceType, pprTheta, pprClassPred )
 import Name            ( Name, setNameUnique, mkSystemTvNameEncoded )
 import VarSet
 import CmdLineOpts     ( dopt, DynFlag(..) )
-import Util            ( nOfThem, isSingleton, equalLength, notNull )
+import Util            ( nOfThem, isSingleton, equalLength, notNull, lengthExceeds )
 import ListSetOps      ( equivClasses, removeDups )
 import Outputable
 \end{code}
@@ -114,6 +112,11 @@ newTyVar kind
   = newUnique  `thenM` \ uniq ->
     newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("t")) kind VanillaTv
 
+newSigTyVar :: Kind -> TcM TcTyVar
+newSigTyVar kind
+  = newUnique  `thenM` \ uniq ->
+    newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("s")) kind SigTv
+
 newTyVarTy  :: Kind -> TcM TcType
 newTyVarTy kind
   = newTyVar kind      `thenM` \ tc_tyvar ->
@@ -141,42 +144,6 @@ newOpenTypeKind
 
 %************************************************************************
 %*                                                                     *
-\subsection{'hole' type variables}
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
-newHoleTyVarTy :: TcM TcType
-  = newUnique  `thenM` \ uniq ->
-    newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("h")) openTypeKind HoleTv    `thenM` \ tv ->
-    returnM (TyVarTy tv)
-
-readHoleResult :: TcType -> TcM TcType
--- Read the answer out of a hole, constructed by newHoleTyVarTy
-readHoleResult (TyVarTy tv)
-  = ASSERT( isHoleTyVar tv )
-    getTcTyVar tv              `thenM` \ maybe_res ->
-    case maybe_res of
-       Just ty -> returnM ty
-       Nothing ->  pprPanic "readHoleResult: empty" (ppr tv)
-readHoleResult ty = pprPanic "readHoleResult: not hole" (ppr ty)
-
-zapToType :: TcType -> TcM TcType
-zapToType (TyVarTy tv)
-  | isHoleTyVar tv
-  = getTcTyVar tv              `thenM` \ maybe_res ->
-    case maybe_res of
-       Nothing -> newTyVarTy openTypeKind      `thenM` \ ty ->
-                  putTcTyVar tv ty             `thenM_`
-                  returnM ty
-       Just ty  -> returnM ty  -- No need to loop; we never
-                                       -- have chains of holes
-
-zapToType other_ty = returnM other_ty
-\end{code}                
-
-%************************************************************************
-%*                                                                     *
 \subsection{Type instantiation}
 %*                                                                     *
 %************************************************************************
@@ -782,13 +749,25 @@ kindErr kind       = ptext SLIT("Expecting an ordinary type, but found a type of
 %************************************************************************
 
 \begin{code}
+-- Enumerate the contexts in which a "source type", <S>, can occur
+--     Eq a 
+-- or  ?x::Int
+-- or  r <: {x::Int}
+-- or  (N a) where N is a newtype
+
 data SourceTyCtxt
   = ClassSCCtxt Name   -- Superclasses of clas
-  | SigmaCtxt          -- Context of a normal for-all type
-  | DataTyCtxt Name    -- Context of a data decl
+                       --      class <S> => C a where ...
+  | SigmaCtxt          -- Theta part of a normal for-all type
+                       --      f :: <S> => a -> a
+  | DataTyCtxt Name    -- Theta part of a data decl
+                       --      data <S> => T a = MkT a
   | TypeCtxt           -- Source type in an ordinary type
+                       --      f :: N a -> N a
   | InstThetaCtxt      -- Context of an instance decl
+                       --      instance <S> => C [a] where ...
   | InstHeadCtxt       -- Head of an instance decl
+                       --      instance ... => Eq a where ...
                
 pprSourceTyCtxt (ClassSCCtxt c) = ptext SLIT("the super-classes of class") <+> quotes (ppr c)
 pprSourceTyCtxt SigmaCtxt       = ptext SLIT("the context of a polymorphic type")