[project @ 2001-02-26 15:06:57 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index a1bac30..37fdce6 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 )
@@ -24,10 +24,9 @@ import Inst          ( InstOrigin(..),
                          instToId, tcInstId
                        )
 import TcBinds         ( tcBindsAndThen )
-import TcEnv           ( TcTyThing(..), 
-                         tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe,
-                         tcLookupTyCon, tcLookupDataCon, tcLookup,
-                         tcExtendGlobalTyVars
+import TcEnv           ( tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe,
+                         tcLookupTyCon, tcLookupDataCon, tcLookupId,
+                         tcExtendGlobalTyVars, tcLookupSyntaxName
                        )
 import TcMatches       ( tcMatchesCase, tcMatchLambda, tcStmts )
 import TcMonoType      ( tcHsSigType, checkSigTyVars, sigCtxt )
@@ -58,7 +57,7 @@ import TysWiredIn     ( boolTy, mkListTy, listTyCon )
 import TcUnify         ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy )
 import PrelNames       ( cCallableClassName, 
                          cReturnableClassName, 
-                         enumFromName, enumFromThenName,
+                         enumFromName, enumFromThenName, negateName,
                          enumFromToName, enumFromThenToName,
                          thenMName, failMName, returnMName, ioTyConName
                        )
@@ -196,8 +195,9 @@ tcMonoExpr (HsLit lit)     res_ty = tcLit lit res_ty
 tcMonoExpr (HsOverLit lit) res_ty = newOverloadedLit (LiteralOrigin lit) lit res_ty
 tcMonoExpr (HsPar expr)    res_ty = tcMonoExpr expr res_ty
 
-tcMonoExpr (NegApp expr neg) res_ty
-  = tcMonoExpr (HsApp (HsVar neg) expr) res_ty
+tcMonoExpr (NegApp expr) res_ty
+  = tcLookupSyntaxName negateName      `thenNF_Tc` \ neg ->
+    tcMonoExpr (HsApp (HsVar neg) expr) res_ty
 
 tcMonoExpr (HsLam match) res_ty
   = tcMatchLambda match res_ty                 `thenTc` \ (match',lie) ->
@@ -644,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}
@@ -752,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}