[project @ 2003-02-26 17:04: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 0f69371..6cfd445 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -13,18 +13,16 @@ import {-# SOURCE #-}       TcSplice( tcSpliceExpr, tcBracket )
 import HsSyn           ( HsReify(..), ReifyFlavour(..) )
 import TcType          ( isTauTy )
 import TcEnv           ( bracketOK, tcMetaTy, checkWellStaged, metaLevel )
-import TcSimplify      ( tcSimplifyBracket )
 import Name            ( isExternalName )
 import qualified DsMeta
 #endif
 
 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,
@@ -35,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,
@@ -43,17 +41,16 @@ import TcMType              ( tcInstTyVars, tcInstType, newHoleTyVarTy, zapToType,
 import TcType          ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv),
                          tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
                          isSigmaTy, mkFunTy, mkFunTys,
-                         mkTyConApp, mkClassPred, tcFunArgTy,
+                         mkTyConApp, mkClassPred, 
                          tyVarsOfTypes, isLinearPred,
                          liftedTypeKind, openTypeKind, 
-                         tcSplitSigmaTy, tcTyConAppTyCon,
-                         tidyOpenType
+                         tcSplitSigmaTy, tidyOpenType
                        )
 import FieldLabel      ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
 import Id              ( Id, idType, recordSelectorFieldLabel, isRecordSelector )
 import DataCon         ( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks, dataConWrapId )
 import Name            ( Name )
-import TyCon           ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons, isClassTyCon )
+import TyCon           ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons )
 import Subst           ( mkTopTyVarSubst, substTheta, substTy )
 import VarSet          ( emptyVarSet, elemVarSet )
 import TysWiredIn      ( boolTy )
@@ -138,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)
@@ -174,7 +164,8 @@ tcMonoExpr (HsPar expr)    res_ty  = tcMonoExpr expr res_ty `thenM` \ expr' ->
 tcMonoExpr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty    `thenM` \ expr' ->
                                     returnM (HsSCC lbl expr')
 
-
+tcMonoExpr (HsCoreAnn lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' ->  -- hdaume: core annotation
+                                         returnM (HsCoreAnn lbl expr')
 tcMonoExpr (NegApp expr neg_name) res_ty
   = tcMonoExpr (HsApp (HsVar neg_name) expr) res_ty
        -- ToDo: use tcSyntaxName
@@ -616,7 +607,7 @@ tcMonoExpr (PArrSeqIn _) _
        -- Rename excludes these cases otherwise
 
 tcMonoExpr (HsSplice n expr loc) res_ty = addSrcLoc loc (tcSpliceExpr n expr res_ty)
-tcMonoExpr (HsBracket brack loc) res_ty = addSrcLoc loc (tcBracket brack)
+tcMonoExpr (HsBracket brack loc) res_ty = addSrcLoc loc (tcBracket brack res_ty)
 
 tcMonoExpr (HsReify (Reify flavour name)) res_ty
   = addErrCtxt (ptext SLIT("At the reification of") <+> ppr name)      $
@@ -833,7 +824,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)