[project @ 2003-04-10 15:46:11 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 296c504..8230d2e 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -19,11 +19,10 @@ import qualified DsMeta
 
 import HsSyn           ( HsExpr(..), HsLit(..), ArithSeqInfo(..), recBindFields )
 import RnHsSyn         ( RenamedHsExpr, RenamedRecordBinds )
-import TcHsSyn         ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, mkHsLet )
+import TcHsSyn         ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, mkHsLet, (<$>) )
 import TcRnMonad
-import TcUnify         ( tcSubExp, tcGen, (<$>),
-                         unifyTauTy, unifyFunTy, unifyListTy, unifyPArrTy,
-                         unifyTupleTy )
+import TcUnify         ( tcSubExp, tcGen,
+                         unifyTauTy, unifyFunTy, unifyListTy, unifyPArrTy, unifyTupleTy )
 import BasicTypes      ( isMarkedStrict )
 import Inst            ( InstOrigin(..), 
                          newOverloadedLit, newMethodFromName, newIPDict,
@@ -34,7 +33,7 @@ import TcBinds                ( tcBindsAndThen )
 import TcEnv           ( tcLookupClass, tcLookupGlobal_maybe, tcLookupIdLvl,
                          tcLookupTyCon, tcLookupDataCon, tcLookupId
                        )
-import TcMatches       ( tcMatchesCase, tcMatchLambda, tcDoStmts )
+import TcMatches       ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig )
 import TcMonoType      ( tcHsSigType, UserTypeCtxt(..) )
 import TcPat           ( badFieldCon )
 import TcMType         ( tcInstTyVars, tcInstType, newHoleTyVarTy, zapToType,
@@ -136,17 +135,10 @@ tcMonoExpr (HsIPVar ip) res_ty
 
 \begin{code}
 tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
- = addErrCtxt (exprSigCtxt in_expr)    $
-   tcHsSigType ExprSigCtxt poly_ty     `thenM` \ sig_tc_ty ->
-   tcExpr expr sig_tc_ty               `thenM` \ expr' ->
-
-       -- Must instantiate the outer for-alls of sig_tc_ty
-       -- else we risk instantiating a ? res_ty to a forall-type
-       -- which breaks the invariant that tcMonoExpr only returns phi-types
-   tcInstCall SignatureOrigin sig_tc_ty        `thenM` \ (inst_fn, inst_sig_ty) ->
-   tcSubExp res_ty inst_sig_ty         `thenM` \ co_fn ->
-
-   returnM (co_fn <$> inst_fn expr')
+ = addErrCtxt (exprSigCtxt in_expr)                    $
+   tcHsSigType ExprSigCtxt poly_ty                     `thenM` \ sig_tc_ty ->
+   tcThingWithSig sig_tc_ty (tcMonoExpr expr) res_ty   `thenM` \ (co_fn, expr') ->
+   returnM (co_fn <$> expr')
 
 tcMonoExpr (HsType ty) res_ty
   = failWithTc (text "Can't handle type argument:" <+> ppr ty)
@@ -666,17 +658,33 @@ tcApp fun args res_ty
        split_fun_ty fun_ty (length args)
     )                                          `thenM` \ (expected_arg_tys, actual_result_ty) ->
 
-       -- Now typecheck the args
-    mappM (tcArg fun)
-         (zip3 args expected_arg_tys [1..])    `thenM` \ args' ->
-
-       -- Unify with expected result after type-checking the args
-       -- so that the info from args percolates to actual_result_ty.
+       -- Unify with expected result before (was: after) type-checking the args
+       -- so that the info from res_ty (was: args) percolates to args (was actual_result_ty).
        -- This is when we might detect a too-few args situation.
        -- (One can think of cases when the opposite order would give
        -- a better error message.)
+       -- [March 2003: I'm experimenting with putting this first.  Here's an 
+       --              example where it actually makes a real difference
+       --    class C t a b | t a -> b
+       --    instance C Char a Bool
+       --
+       --    data P t a = forall b. (C t a b) => MkP b
+       --    data Q t   = MkQ (forall a. P t a)
+    
+       --    f1, f2 :: Q Char;
+       --    f1 = MkQ (MkP True)
+       --    f2 = MkQ (MkP True :: forall a. P Char a)
+       --
+       -- With the change, f1 will type-check, because the 'Char' info from
+       -- the signature is propagated into MkQ's argument. With the check
+       -- in the other order, the extra signature in f2 is reqd.]
+
     addErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty)
-                 (tcSubExp res_ty actual_result_ty)    `thenM` \ co_fn ->
+               (tcSubExp res_ty actual_result_ty)      `thenM` \ co_fn ->
+
+       -- Now typecheck the args
+    mappM (tcArg fun)
+         (zip3 args expected_arg_tys [1..])    `thenM` \ args' ->
 
     returnM (co_fn <$> foldl HsApp fun' args') 
 
@@ -832,7 +840,7 @@ tcId name   -- Look up the Id and instantiate its type
     loop fun fun_ty 
        | isSigmaTy fun_ty
        = tcInstCall orig fun_ty        `thenM` \ (inst_fn, tau) ->
-         loop (inst_fn fun) tau
+         loop (inst_fn <$> fun) tau
 
        | otherwise
        = returnM (fun, fun_ty)