[project @ 2000-05-10 11:28:47 by keithw]

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

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index a9880a2..100a838 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -13,8 +13,8 @@ import HsSyn          ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
                          mkMonoBind, nullMonoBinds
                        )
 import RnHsSyn         ( RenamedHsExpr, RenamedRecordBinds )
-import TcHsSyn         ( TcExpr, TcRecordBinds,
-                         mkHsTyApp, mkHsLet, maybeBoxedPrimType
+import TcHsSyn         ( TcExpr, TcRecordBinds, mkHsConApp,
+                         mkHsTyApp, mkHsLet
                        )
 
 import TcMonad
@@ -35,7 +35,7 @@ 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, partitionPredsOfLIE )
 import TcType          ( TcType, TcTauType,
@@ -50,15 +50,15 @@ import Id           ( idType, recordSelectorFieldLabel,
                          isRecordSelector,
                          Id, mkVanillaId
                        )
-import DataCon         ( dataConFieldLabels, dataConSig, dataConId,
+import DataCon         ( dataConFieldLabels, dataConSig, 
                          dataConStrictMarks, StrictnessMark(..)
                        )
 import Name            ( Name, getName )
 import Type            ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
                          ipName_maybe,
                          splitFunTy_maybe, splitFunTys, isNotUsgTy,
-                         mkTyConApp,
-                         splitForAllTys, splitRhoTy,
+                         mkTyConApp, splitSigmaTy, 
+                         splitRhoTy,
                          isTauTy, tyVarsOfType, tyVarsOfTypes, 
                          isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
                          boxedTypeKind, mkArrowKind,
@@ -131,6 +131,7 @@ tcPolyExpr arg expected_arg_ty
     tcInstTcType expected_arg_ty       `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
     let
        (sig_theta, sig_tau) = splitRhoTy sig_rho
+       free_tyvars          = tyVarsOfType expected_arg_ty
     in
        -- Type-check the arg and unify with expected type
     tcMonoExpr arg sig_tau                             `thenTc` \ (arg', lie_arg) ->
@@ -146,10 +147,10 @@ tcPolyExpr arg expected_arg_ty
        -- Conclusion: include the free vars of the expected arg type in the
        -- list of "free vars" for the signature check.
 
-    tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty)                $
-    tcAddErrCtxtM (sigCtxt sig_msg expected_arg_ty)            $
+    tcExtendGlobalTyVars free_tyvars                             $
+    tcAddErrCtxtM (sigCtxt sig_msg sig_tyvars sig_theta sig_tau)  $
 
-    checkSigTyVars sig_tyvars                  `thenTc` \ zonked_sig_tyvars ->
+    checkSigTyVars sig_tyvars free_tyvars      `thenTc` \ zonked_sig_tyvars ->
 
     newDicts SignatureOrigin sig_theta         `thenNF_Tc` \ (sig_dicts, dict_ids) ->
        -- ToDo: better origin
@@ -170,8 +171,7 @@ tcPolyExpr arg expected_arg_ty
     returnTc ( generalised_arg, free_insts,
               arg', sig_tau, lie_arg )
   where
-    sig_msg ty = sep [ptext SLIT("In an expression with expected type:"),
-                     nest 4 (ppr ty)]
+    sig_msg = ptext SLIT("When checking an expression type signature")
 \end{code}
 
 %************************************************************************
@@ -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,9 +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),
-                     -- do the wrapping in the newtype constructor here
+    returnTc (HsCCall lbl args' may_gc is_asm io_result_ty,
              foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
 \end{code}
 
@@ -480,11 +478,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
@@ -564,8 +562,9 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
        -- Figure out the tycon and data cons from the first field name
     let
        (Just sel_id : _)         = maybe_sel_ids
-       (_, tau)                  = ASSERT( isNotUsgTy (idType sel_id) )
-                                    splitForAllTys (idType sel_id)
+       (_, _, tau)               = ASSERT( isNotUsgTy (idType sel_id) )
+                                    splitSigmaTy (idType sel_id)       -- Selectors can be overloaded
+                                                                       -- when the data type has a context
        Just (data_ty, _)         = splitFunTy_maybe tau        -- Must succeed since sel_id is a selector
        (tycon, _, data_cons)     = splitAlgTyConApp data_ty
        (con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
@@ -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