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,
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,
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 )
\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)
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
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)