[project @ 1997-07-05 02:33:54 by sof]

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

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 7b53c42..48c62a0 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -44,13 +44,12 @@ import TcType               ( SYN_IE(TcType), TcMaybe(..),
                          newTyVarTy, newTyVarTys, zonkTcTyVars, zonkTcType )
 import TcKind          ( TcKind )
 
-import Class           ( SYN_IE(Class), classSig )
-import FieldLabel      ( fieldLabelName, fieldLabelType )
+import Class           ( SYN_IE(Class) )
+import FieldLabel      ( FieldLabel, fieldLabelName, fieldLabelType )
 import Id              ( idType, dataConFieldLabels, dataConSig, recordSelectorFieldLabel,
                          isRecordSelector,
                          SYN_IE(Id), GenId
                        )
-import FieldLabel      ( FieldLabel )
 import Kind            ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
 import Name            ( Name{-instance Eq-} )
 import Type            ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy,
@@ -296,7 +295,7 @@ tcExpr (HsLet binds expr)
   where
     tc_expr expr = tcExpr expr `thenTc` \ (expr', lie, ty) ->
                   returnTc ((expr',ty), lie)
-    combiner bind (expr, ty) = (HsLet bind expr, ty)
+    combiner is_rec bind (expr, ty) = (HsLet (MonoBind bind [] is_rec) expr, ty)
 
 tcExpr in_expr@(HsCase expr matches src_loc)
   = tcAddSrcLoc src_loc        $
@@ -332,16 +331,16 @@ tcExpr expr@(HsDo do_or_lc stmts src_loc)
 \end{code}
 
 \begin{code}
-tcExpr (ExplicitList [])
-  = newTyVarTy mkBoxedTypeKind         `thenNF_Tc` \ tyvar_ty ->
-    returnTc (ExplicitListOut tyvar_ty [], emptyLIE, mkListTy tyvar_ty)
-
-
 tcExpr in_expr@(ExplicitList exprs)    -- Non-empty list
-  = tcExprs exprs                      `thenTc` \ (exprs', lie, tys@(elt_ty:_)) ->
-    tcAddErrCtxt (listCtxt in_expr) $
-    unifyTauTyList tys                         `thenTc_`
-    returnTc (ExplicitListOut elt_ty exprs', lie, mkListTy elt_ty)
+  = newTyVarTy mkBoxedTypeKind         `thenNF_Tc` \ elt_ty ->
+    mapAndUnzipTc (tc_elt elt_ty) exprs        `thenTc` \ (exprs', lies) ->
+    returnTc (ExplicitListOut elt_ty exprs', plusLIEs lies, mkListTy elt_ty)
+  where
+    tc_elt elt_ty expr
+      = tcAddErrCtxt (listCtxt expr) $
+       tcExpr expr                     `thenTc` \ (expr', lie, expr_ty) ->
+       unifyTauTy elt_ty expr_ty       `thenTc_`
+       returnTc (expr', lie)
 
 tcExpr (ExplicitTuple exprs)
   = tcExprs exprs                      `thenTc` \ (exprs', lie, tys) ->
@@ -422,7 +421,6 @@ tcExpr (RecordUpd record_expr rbinds)
        -- Check for bad fields
     checkTc (any (null . badFields rbinds) data_cons)
            (badFieldsUpd rbinds)               `thenTc_`
-
        -- STEP 3
        -- Typecheck the update bindings.
        -- (Do this after checking for bad fields in case there's a field that
@@ -887,7 +885,7 @@ tcStmt tc_expr do_or_lc m combine (LetStmt binds) do_next
        binds
        do_next
      where
-       combine' binds' thing' = combine (LetStmt binds') Nothing thing'
+       combine' is_rec binds' thing' = combine (LetStmt (MonoBind binds' [] is_rec)) Nothing thing'
 \end{code}
 
 %************************************************************************
@@ -995,28 +993,28 @@ branchCtxt b1 b2 sty
           pp_nest_hang "`else' branch:" (ppr sty b2)]
 
 caseCtxt expr sty
-  = hang (ptext SLIT("In a case expression:")) 4 (ppr sty expr)
+  = hang (ptext SLIT("In the case expression")) 4 (ppr sty expr)
 
 exprSigCtxt expr sty
   = hang (ptext SLIT("In an expression with a type signature:"))
         4 (ppr sty expr)
 
 listCtxt expr sty
-  = hang (ptext SLIT("In a list expression:")) 4 (ppr sty expr)
+  = hang (ptext SLIT("In the list element")) 4 (ppr sty expr)
 
 predCtxt expr sty
-  = hang (ptext SLIT("In a predicate expression:")) 4 (ppr sty expr)
+  = hang (ptext SLIT("In the predicate expression")) 4 (ppr sty expr)
 
 sectionRAppCtxt expr sty
-  = hang (ptext SLIT("In a right section:")) 4 (ppr sty expr)
+  = hang (ptext SLIT("In the right section")) 4 (ppr sty expr)
 
 sectionLAppCtxt expr sty
-  = hang (ptext SLIT("In a left section:")) 4 (ppr sty expr)
+  = hang (ptext SLIT("In the left section")) 4 (ppr sty expr)
 
 funAppCtxt fun arg_no arg sty
   = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"), 
                    ppr sty fun <> text ", namely"])
-        4 (pprParendExpr sty arg)
+        4 (ppr sty arg)
 
 stmtCtxt ListComp stmt sty
   = hang (ptext SLIT("In a list-comprehension qualifer:"))