[project @ 2000-03-24 17:49:29 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 7aecdaa..f622d1c 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -9,11 +9,11 @@ module TcExpr ( tcApp, tcExpr, tcPolyExpr, tcId ) where
 #include "HsVersions.h"
 
 import HsSyn           ( HsExpr(..), HsLit(..), ArithSeqInfo(..), 
-                         HsBinds(..), Stmt(..), StmtCtxt(..),
+                         HsBinds(..), MonoBinds(..), Stmt(..), StmtCtxt(..),
                          mkMonoBind, nullMonoBinds
                        )
 import RnHsSyn         ( RenamedHsExpr, RenamedRecordBinds )
-import TcHsSyn         ( TcExpr, TcRecordBinds,
+import TcHsSyn         ( TcExpr, TcRecordBinds, mkHsConApp,
                          mkHsTyApp, mkHsLet, maybeBoxedPrimType
                        )
 
@@ -22,10 +22,10 @@ import BasicTypes   ( RecFlag(..) )
 
 import Inst            ( Inst, InstOrigin(..), OverloadedLit(..),
                          LIE, emptyLIE, unitLIE, consLIE, plusLIE, plusLIEs,
-                         lieToList, listToLIE, tyVarsOfLIE, zonkLIE,
+                         lieToList, listToLIE,
                          newOverloadedLit, newMethod, newIPDict,
                          instOverloadedFun, newDicts, newClassDicts,
-                         partitionLIEbyMeth, getIPsOfLIE, instToId, ipToId
+                         getIPsOfLIE, instToId, ipToId
                        )
 import TcBinds         ( tcBindsAndThen )
 import TcEnv           ( tcInstId,
@@ -35,9 +35,9 @@ import TcEnv          ( tcInstId,
                          tcLookupTyCon, tcLookupDataCon
                        )
 import TcMatches       ( tcMatchesCase, tcMatchLambda, tcStmts )
-import TcMonoType      ( tcHsType, checkSigTyVars, sigCtxt )
+import TcMonoType      ( tcHsSigType, checkSigTyVars, sigCtxt )
 import TcPat           ( badFieldCon )
-import TcSimplify      ( tcSimplify, tcSimplifyAndCheck )
+import TcSimplify      ( tcSimplify, tcSimplifyAndCheck, partitionPredsOfLIE )
 import TcType          ( TcType, TcTauType,
                          tcInstTyVars,
                          tcInstTcType, tcSplitRhoTy,
@@ -50,7 +50,7 @@ import Id             ( idType, recordSelectorFieldLabel,
                          isRecordSelector,
                          Id, mkVanillaId
                        )
-import DataCon         ( dataConFieldLabels, dataConSig, dataConId,
+import DataCon         ( dataConFieldLabels, dataConSig, 
                          dataConStrictMarks, StrictnessMark(..)
                        )
 import Name            ( Name, getName )
@@ -354,7 +354,7 @@ arg/result types); unify them with the args/result; and store them for
 later use.
 
 \begin{code}
-tcMonoExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
+tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
   =    -- Get the callable and returnable classes.
     tcLookupClassByKey cCallableClassKey       `thenNF_Tc` \ cCallableClass ->
     tcLookupClassByKey cReturnableClassKey     `thenNF_Tc` \ cReturnableClass ->
@@ -390,8 +390,7 @@ tcMonoExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
        -- 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, _) ->
-    returnTc (HsApp (HsVar (dataConId ioDataCon) `TyApp` [result_ty])
-                   (CCall lbl args' may_gc is_asm result_ty),
+    returnTc (mkHsConApp ioDataCon [result_ty] [HsCCall lbl args' may_gc is_asm result_ty],
                      -- do the wrapping in the newtype constructor here
              foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
 \end{code}
@@ -480,11 +479,11 @@ tcMonoExpr expr@(RecordCon con_name rbinds) res_ty
     let
        (_, record_ty) = splitFunTys con_tau
     in
-       -- Con is syntactically constrained to be a data constructor
     ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
     unifyTauTy res_ty record_ty          `thenTc_`
 
        -- Check that the record bindings match the constructor
+       -- con_name is syntactically constrained to be a data constructor
     tcLookupDataCon con_name   `thenTc` \ (data_con, _, _) ->
     let
        bad_fields = badFields rbinds data_con
@@ -700,7 +699,7 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
 \begin{code}
 tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
  = tcSetErrCtxt (exprSigCtxt in_expr)  $
-   tcHsType  poly_ty           `thenTc` \ sig_tc_ty ->
+   tcHsSigType  poly_ty                `thenTc` \ sig_tc_ty ->
 
    if not (isForAllTy sig_tc_ty) then
        -- Easy case
@@ -731,19 +730,27 @@ Implicit Parameter bindings.
 tcMonoExpr (HsWith expr binds) res_ty
   = tcMonoExpr expr res_ty             `thenTc` \ (expr', lie) ->
     tcIPBinds binds                    `thenTc` \ (binds', types, lie2) ->
-    partitionLIEbyMeth isBound lie     `thenTc` \ (ips, lie') ->
-    zonkLIE ips                                `thenTc` \ ips' ->
-    tcSimplify (text "With!") (tyVarsOfLIE ips') ips' `thenTc` \ res@(_, dict_binds, _) ->
+    partitionPredsOfLIE isBound lie    `thenTc` \ (ips, lie', dict_binds) ->
+    pprTrace "tcMonoExpr With" (ppr (ips, lie', dict_binds)) $
     let expr'' = if nullMonoBinds dict_binds
                 then expr'
-                else HsLet (MonoBind dict_binds [] NonRecursive) expr' in
-    tcCheckIPBinds binds' types ips'   `thenTc_`
+                else HsLet (mkMonoBind (revBinds dict_binds) [] NonRecursive)
+                           expr'
+    in
+    tcCheckIPBinds binds' types ips    `thenTc_`
     returnTc (HsWith expr'' binds', lie' `plusLIE` lie2)
   where isBound p
          = case ipName_maybe p of
            Just n -> n `elem` names
            Nothing -> False
        names = map fst binds
+       -- revBinds is used because tcSimplify outputs the bindings
+       -- out-of-order.  it's not a problem elsewhere because these
+       -- bindings are normally used in a recursive let
+       -- ZZ probably need to find a better solution
+       revBinds (b1 `AndMonoBinds` b2) =
+           (revBinds b2) `AndMonoBinds` (revBinds b1)
+       revBinds b = b
 
 tcIPBinds ((name, expr) : binds)
   = newTyVarTy_OpenKind                `thenTc` \ ty ->