[project @ 1996-07-25 20:43:49 by partain]

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

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index d3860c7..9c59b43 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -15,29 +15,30 @@ import HsSyn                ( HsExpr(..), Qualifier(..), Stmt(..),
                          ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
                          Match, Fake, InPat, OutPat, PolyType,
                          failureFreePat, collectPatBinders )
-import RnHsSyn         ( RenamedHsExpr(..), RenamedQual(..),
-                         RenamedStmt(..), RenamedRecordBinds(..),
+import RnHsSyn         ( SYN_IE(RenamedHsExpr), SYN_IE(RenamedQual),
+                         SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds),
                          RnName{-instance Outputable-}
                        )
-import TcHsSyn         ( TcExpr(..), TcQual(..), TcStmt(..),
-                         TcIdOcc(..), TcRecordBinds(..),
+import TcHsSyn         ( SYN_IE(TcExpr), SYN_IE(TcQual), SYN_IE(TcStmt),
+                         TcIdOcc(..), SYN_IE(TcRecordBinds),
                          mkHsTyApp
                        )
 
 import TcMonad         hiding ( rnMtoTcM )
 import Inst            ( Inst, InstOrigin(..), OverloadedLit(..),
-                         LIE(..), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
+                         SYN_IE(LIE), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
                          newMethod, newMethodWithGivenTy, newDicts )
 import TcBinds         ( tcBindsAndThen )
 import TcEnv           ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
                          tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars,
                          tcExtendGlobalTyVars
                        )
+import SpecEnv         ( SpecEnv )
 import TcMatches       ( tcMatchesCase, tcMatch )
 import TcMonoType      ( tcPolyType )
 import TcPat           ( tcPat )
 import TcSimplify      ( tcSimplifyAndCheck, tcSimplifyRank2 )
-import TcType          ( TcType(..), TcMaybe(..),
+import TcType          ( SYN_IE(TcType), TcMaybe(..),
                          tcInstId, tcInstType, tcInstSigTcType,
                          tcInstSigType, tcInstTcType, tcInstTheta,
                          newTyVarTy, zonkTcTyVars, zonkTcType )
@@ -57,11 +58,11 @@ import Type         ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy,
                        )
 import TyVar           ( GenTyVar, SYN_IE(TyVarSet), unionTyVarSets, mkTyVarSet )
 import TysPrim         ( intPrimTy, charPrimTy, doublePrimTy,
-                         floatPrimTy, addrPrimTy
+                         floatPrimTy, addrPrimTy, realWorldTy
                        )
 import TysWiredIn      ( addrTy,
                          boolTy, charTy, stringTy, mkListTy,
-                         mkTupleTy, mkPrimIoTy, primIoDataCon
+                         mkTupleTy, mkPrimIoTy, stDataCon
                        )
 import Unify           ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
 import Unique          ( Unique, cCallableClassKey, cReturnableClassKey, 
@@ -229,7 +230,7 @@ tcExpr in_expr@(SectionR op expr)
     newTyVarTy mkTypeKind      `thenNF_Tc` \ ty1 ->
     newTyVarTy mkTypeKind      `thenNF_Tc` \ ty2 ->
     tcAddErrCtxt (sectionRAppCtxt in_expr) $
-    unifyTauTy op_ty (mkFunTys [ty1, expr_ty] ty2)     `thenTc_`
+    unifyTauTy (mkFunTys [ty1, expr_ty] ty2) op_ty      `thenTc_`
 
     returnTc (SectionR op' expr', lie1 `plusLIE` lie2, mkFunTy ty1 ty2)
 \end{code}
@@ -269,7 +270,7 @@ tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty)
     mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args arg_tys)    `thenNF_Tc` \ ccarg_dicts_s ->
     newDicts result_origin [(cReturnableClass, result_ty)]         `thenNF_Tc` \ (ccres_dict, _) ->
 
-    returnTc (HsCon primIoDataCon [result_ty] [CCall lbl args' may_gc is_asm result_ty],
+    returnTc (HsCon stDataCon [realWorldTy, result_ty] [CCall 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,
              mkPrimIoTy result_ty)
@@ -303,7 +304,7 @@ tcExpr (HsIf pred b1 b2 src_loc)
     tcExpr pred                        `thenTc`    \ (pred',lie1,predTy) ->
 
     tcAddErrCtxt (predCtxt pred) (
-      unifyTauTy predTy boolTy
+      unifyTauTy boolTy predTy
     )                          `thenTc_`
 
     tcExpr b1                  `thenTc`    \ (b1',lie2,result_ty) ->
@@ -376,7 +377,8 @@ tcExpr (RecordUpd record_expr rbinds)
        -- Check that the field names are plausible
     zonkTcType record_ty               `thenNF_Tc` \ record_ty' ->
     let
-       (tycon, inst_tys, data_cons) = trace "TcExpr.getAppDataTyCon" $ getAppDataTyCon record_ty'
+       (tycon, inst_tys, data_cons) = --trace "TcExpr.getAppDataTyCon" $
+                                      getAppDataTyCon record_ty'
        -- The record binds are non-empty (syntax); so at least one field
        -- label will have been unified with record_ty by tcRecordBinds;
        -- field labels must be of data type; hencd the getAppDataTyCon must succeed.
@@ -469,7 +471,7 @@ tcExpr in_expr@(ExprWithTySig expr poly_ty)
    let
        (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
    in
-   unifyTauTy tau_ty sig_tau'          `thenTc_`
+   unifyTauTy sig_tau' tau_ty          `thenTc_`
 
        -- Check the type variables of the signature
    checkSigTyVars sig_tyvars' sig_tau' `thenTc_`
@@ -783,7 +785,7 @@ tcDoStmts stmts src_loc
                -- See comments with tcListComp on GeneratorQual
 
                get_m_arg exp_ty        `thenTc` \ a ->
-               unifyTauTy a pat_ty     `thenTc_`
+               unifyTauTy pat_ty a     `thenTc_`
                returnTc (a, pat', exp', pat_lie `plusLIE` exp_lie)
          ))                            `thenTc` \ (a, pat', exp', stmt_lie) ->
          go stmts                      `thenTc` \ (stmts', stmts_lie, stmts_ty) ->