[project @ 2001-03-13 14:58:25 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 59730b2..ebc25af 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -9,7 +9,7 @@ module TcExpr ( tcApp, tcExpr, tcMonoExpr, tcPolyExpr, tcId ) where
 #include "HsVersions.h"
 
 import HsSyn           ( HsExpr(..), HsLit(..), ArithSeqInfo(..), 
-                         StmtCtxt(..), mkMonoBind
+                         HsMatchContext(..), mkMonoBind
                        )
 import RnHsSyn         ( RenamedHsExpr, RenamedRecordBinds )
 import TcHsSyn         ( TcExpr, TcRecordBinds, mkHsLet )
@@ -20,13 +20,12 @@ import BasicTypes   ( RecFlag(..) )
 import Inst            ( InstOrigin(..), 
                          LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs,
                          newOverloadedLit, newMethod, newIPDict,
-                         newDicts, newClassDicts,
+                         newDicts, 
                          instToId, tcInstId
                        )
 import TcBinds         ( tcBindsAndThen )
-import TcEnv           ( TcTyThing(..), 
-                         tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe,
-                         tcLookupTyCon, tcLookupDataCon, tcLookup,
+import TcEnv           ( tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe,
+                         tcLookupTyCon, tcLookupDataCon, tcLookupId,
                          tcExtendGlobalTyVars, tcLookupSyntaxName
                        )
 import TcMatches       ( tcMatchesCase, tcMatchLambda, tcStmts )
@@ -45,14 +44,14 @@ import DataCon              ( dataConFieldLabels, dataConSig,
 import Name            ( Name )
 import Type            ( mkFunTy, mkAppTy, mkTyConTy,
                          splitFunTy_maybe, splitFunTys,
-                         mkTyConApp, splitSigmaTy, 
+                         mkTyConApp, splitSigmaTy, mkClassPred,
                          isTauTy, tyVarsOfType, tyVarsOfTypes, 
                          isSigmaTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
                          liftedTypeKind, openTypeKind, mkArrowKind,
                          tidyOpenType
                        )
 import TyCon           ( TyCon, tyConTyVars )
-import Subst           ( mkTopTyVarSubst, substClasses, substTy )
+import Subst           ( mkTopTyVarSubst, substTheta, substTy )
 import VarSet          ( elemVarSet )
 import TysWiredIn      ( boolTy, mkListTy, listTyCon )
 import TcUnify         ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy )
@@ -269,8 +268,8 @@ tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
     tcLookupTyCon ioTyConName          `thenNF_Tc` \ ioTyCon ->
     let
        new_arg_dict (arg, arg_ty)
-         = newClassDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
-                         [(cCallableClass, [arg_ty])]  `thenNF_Tc` \ arg_dicts ->
+         = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
+                    [mkClassPred cCallableClass [arg_ty]]      `thenNF_Tc` \ arg_dicts ->
            returnNF_Tc arg_dicts       -- Actually a singleton bag
 
        result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
@@ -296,7 +295,7 @@ tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
        -- Construct the extra insts, which encode the
        -- constraints on the argument and result types.
     mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys)   `thenNF_Tc` \ ccarg_dicts_s ->
-    newClassDicts result_origin [(cReturnableClass, [result_ty])]      `thenNF_Tc` \ ccres_dict ->
+    newDicts result_origin [mkClassPred cReturnableClass [result_ty]]  `thenNF_Tc` \ ccres_dict ->
     returnTc (HsCCall lbl args' may_gc is_asm io_result_ty,
              mkLIE (ccres_dict ++ concat ccarg_dicts_s) `plusLIE` args_lie)
 \end{code}
@@ -533,9 +532,9 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
     let
        (tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
        inst_env = mkTopTyVarSubst tyvars result_inst_tys
-       theta'   = substClasses inst_env theta
+       theta'   = substTheta inst_env theta
     in
-    newClassDicts RecordUpdOrigin theta'       `thenNF_Tc` \ dicts ->
+    newDicts RecordUpdOrigin theta'    `thenNF_Tc` \ dicts ->
 
        -- Phew!
     returnTc (RecordUpdOut record_expr' result_record_ty (map instToId dicts) rbinds', 
@@ -645,22 +644,6 @@ tcIPBind (name, expr)
     returnTc ((ip, expr'), lie)
 \end{code}
 
-Typecheck expression which in most cases will be an Id.
-
-\begin{code}
-tcExpr_id :: RenamedHsExpr
-           -> TcM (TcExpr,
-                    LIE,
-                    TcType)
-tcExpr_id id_expr
- = case id_expr of
-       HsVar name -> tcId name                 `thenNF_Tc` \ stuff -> 
-                     returnTc stuff
-       other      -> newTyVarTy openTypeKind   `thenNF_Tc` \ id_ty ->
-                     tcMonoExpr id_expr id_ty  `thenTc`    \ (id_expr', lie_id) ->
-                     returnTc (id_expr', lie_id, id_ty) 
-\end{code}
-
 %************************************************************************
 %*                                                                     *
 \subsection{@tcApp@ typchecks an application}
@@ -753,15 +736,22 @@ tcArg the_fun (arg, expected_arg_ty, arg_no)
 
 \begin{code}
 tcId :: Name -> NF_TcM (TcExpr, LIE, TcType)
+tcId name      -- Look up the Id and instantiate its type
+  = tcLookupId name                    `thenNF_Tc` \ id ->
+    tcInstId id
+\end{code}
+
+Typecheck expression which in most cases will be an Id.
 
-tcId name
-  =    -- Look up the Id and instantiate its type
-    tcLookup name                      `thenNF_Tc` \ thing ->
-    case thing of
-       ATcId tc_id       -> tcInstId tc_id
-       AGlobal (AnId id) -> tcInstId id
+\begin{code}
+tcExpr_id :: RenamedHsExpr -> TcM (TcExpr, LIE, TcType)
+tcExpr_id (HsVar name) = tcId name
+tcExpr_id expr         = newTyVarTy openTypeKind       `thenNF_Tc` \ id_ty ->
+                        tcMonoExpr expr id_ty  `thenTc`    \ (expr', lie_id) ->
+                        returnTc (expr', lie_id, id_ty) 
 \end{code}
 
+
 %************************************************************************
 %*                                                                     *
 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
@@ -935,8 +925,8 @@ Overloaded literals.
 tcLit :: HsLit -> TcType -> TcM (TcExpr, LIE)
 tcLit (HsLitLit s _) res_ty
   = tcLookupClass cCallableClassName                   `thenNF_Tc` \ cCallableClass ->
-    newClassDicts (LitLitOrigin (_UNPK_ s))
-                 [(cCallableClass,[res_ty])]           `thenNF_Tc` \ dicts ->
+    newDicts (LitLitOrigin (_UNPK_ s))
+            [mkClassPred cCallableClass [res_ty]]      `thenNF_Tc` \ dicts ->
     returnTc (HsLit (HsLitLit s res_ty), mkLIE dicts)
 
 tcLit lit res_ty