[project @ 2000-01-28 18:07:55 by sewardj]

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

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index f3903d7..7e5f033 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -9,7 +9,8 @@ module TcExpr ( tcApp, tcExpr, tcPolyExpr, tcId ) where
 #include "HsVersions.h"
 
 import HsSyn           ( HsExpr(..), HsLit(..), ArithSeqInfo(..), 
-                         HsBinds(..), Stmt(..), StmtCtxt(..)
+                         HsBinds(..), Stmt(..), StmtCtxt(..),
+                         mkMonoBind
                        )
 import RnHsSyn         ( RenamedHsExpr, RenamedRecordBinds )
 import TcHsSyn         ( TcExpr, TcRecordBinds,
@@ -21,7 +22,7 @@ import BasicTypes     ( RecFlag(..) )
 
 import Inst            ( Inst, InstOrigin(..), OverloadedLit(..),
                          LIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit,
-                         newMethod, instOverloadedFun, newDicts, instToId )
+                         newMethod, instOverloadedFun, newDicts )
 import TcBinds         ( tcBindsAndThen )
 import TcEnv           ( tcInstId,
                          tcLookupValue, tcLookupClassByKey,
@@ -395,7 +396,7 @@ tcMonoExpr (HsLet binds expr) res_ty
   where
     tc_expr = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
              returnTc (expr', lie)
-    combiner is_rec bind expr = HsLet (MonoBind bind [] is_rec) expr
+    combiner is_rec bind expr = HsLet (mkMonoBind bind [] is_rec) expr
 
 tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
   = tcAddSrcLoc src_loc                        $
@@ -459,8 +460,9 @@ tcMonoExpr (ExplicitTuple exprs boxed) res_ty
                                                        `thenTc` \ (exprs', lies) ->
     returnTc (ExplicitTuple exprs' boxed, plusLIEs lies)
 
-tcMonoExpr (RecordCon con_name rbinds) res_ty
-  = tcId con_name                      `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
+tcMonoExpr expr@(RecordCon con_name rbinds) res_ty
+  = tcAddErrCtxt (recordConCtxt expr)          $
+    tcId con_name                      `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
     let
        (_, record_ty) = splitFunTys con_tau
     in
@@ -522,8 +524,8 @@ tcMonoExpr (RecordCon con_name rbinds) res_ty
 --
 -- All this is done in STEP 4 below.
 
-tcMonoExpr (RecordUpd record_expr rbinds) res_ty
-  = tcAddErrCtxt recordUpdCtxt                 $
+tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
+  = tcAddErrCtxt (recordUpdCtxt        expr)           $
 
        -- STEP 0
        -- Check that the field names are really field names
@@ -1091,7 +1093,8 @@ badFieldsUpd rbinds
   where
     fields = [field | (field, _, _) <- rbinds]
 
-recordUpdCtxt = ptext SLIT("In a record update construct")
+recordUpdCtxt expr = ptext SLIT("In the record update:") <+> ppr expr
+recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr
 
 notSelector field
   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
@@ -1112,7 +1115,6 @@ missingStrictFieldCon con field
 
 missingFieldCon :: Name -> Name -> SDoc
 missingFieldCon con field
-  = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
-         ptext SLIT("does not have the field"), quotes (ppr field)]
-
+  = hsep [ptext SLIT("Field") <+> quotes (ppr field),
+         ptext SLIT("is not initialised")]
 \end{code}