X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=3d7662943a9a813a5aa201c0ef9e342547d36cbb;hb=a63bd8f558fedec86451f36d86833c9afb934ae8;hp=c5e33f3e3fe34359c3b0ce0095333b441de46884;hpb=b2f644fa8edcf8697640c9228089b39030b8b362;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index c5e33f3..3d76629 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -9,11 +9,12 @@ module TcExpr ( tcExpr, tcMonoExpr, tcId ) where #include "HsVersions.h" import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), - HsMatchContext(..), HsDoContext(..), - mkMonoBind + HsMatchContext(..), HsDoContext(..), MonoBinds(..), + mkMonoBind, andMonoBindList ) import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds ) -import TcHsSyn ( TcExpr, TcRecordBinds, simpleHsLitTy, mkHsDictApp, mkHsTyApp ) +import TcHsSyn ( TcExpr, TcRecordBinds, TypecheckedMonoBinds, + simpleHsLitTy, mkHsDictApp, mkHsTyApp, mkHsLet ) import TcMonad import TcUnify ( tcSubExp, tcGen, (<$>), @@ -23,7 +24,7 @@ import BasicTypes ( RecFlag(..), isMarkedStrict ) import Inst ( InstOrigin(..), LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit, newMethodFromName, newIPDict, - newDicts, newMethodWithGivenTy, + newDicts, newMethodWithGivenTy, tcSyntaxName, instToId, tcInstCall, tcInstDataCon ) import TcBinds ( tcBindsAndThen ) @@ -46,7 +47,8 @@ import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv), tidyOpenType ) import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon ) -import Id ( idType, recordSelectorFieldLabel, isRecordSelector, isDataConWrapId_maybe ) +import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector, + isDataConWrapId_maybe, mkSysLocal ) import DataCon ( dataConFieldLabels, dataConSig, dataConStrictMarks ) @@ -55,12 +57,11 @@ import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) import VarSet ( emptyVarSet, elemVarSet ) import TysWiredIn ( boolTy, mkListTy, mkPArrTy ) -import PrelNames ( cCallableClassName, - cReturnableClassName, +import PrelNames ( cCallableClassName, cReturnableClassName, enumFromName, enumFromThenName, enumFromToName, enumFromThenToName, enumFromToPName, enumFromThenToPName, - ioTyConName + ioTyConName, monadNames ) import ListSetOps ( minusList ) import CmdLineOpts @@ -136,13 +137,13 @@ tcMonoExpr (HsIPVar ip) res_ty \begin{code} tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty - = tcHsSigType ExprSigCtxt poly_ty `thenTc` \ sig_tc_ty -> + = tcAddErrCtxt (exprSigCtxt in_expr) $ + tcHsSigType ExprSigCtxt poly_ty `thenTc` \ sig_tc_ty -> tcExpr expr sig_tc_ty `thenTc` \ (expr', lie1) -> -- 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 - tcAddErrCtxt (exprSigCtxt in_expr) $ tcInstCall SignatureOrigin sig_tc_ty `thenNF_Tc` \ (inst_fn, lie2, inst_sig_ty) -> tcSubExp res_ty inst_sig_ty `thenTc` \ (co_fn, lie3) -> @@ -171,6 +172,7 @@ tcMonoExpr (HsPar expr) res_ty = tcMonoExpr expr res_ty tcMonoExpr (NegApp expr neg_name) res_ty = tcMonoExpr (HsApp (HsVar neg_name) expr) res_ty + -- ToDo: use tcSyntaxName tcMonoExpr (HsLam match) res_ty = tcMatchLambda match res_ty `thenTc` \ (match',lie) -> @@ -839,11 +841,11 @@ tcDoStmts ListComp stmts method_names src_loc res_ty stmts_lie) tcDoStmts DoExpr stmts method_names src_loc res_ty - = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenNF_Tc` \ tc_ty -> + = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenNF_Tc` \ m_ty -> newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty -> - unifyTauTy res_ty (mkAppTy tc_ty elt_ty) `thenTc_` + unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenTc_` - tcStmts (DoCtxt DoExpr) (mkAppTy tc_ty, elt_ty) stmts `thenTc` \ (stmts', stmts_lie) -> + tcStmts (DoCtxt DoExpr) (mkAppTy m_ty, elt_ty) stmts `thenTc` \ (stmts', stmts_lie) -> -- Build the then and zero methods in case we need them -- It's important that "then" and "return" appear just once in the final LIE, @@ -853,14 +855,29 @@ tcDoStmts DoExpr stmts method_names src_loc res_ty -- then = then -- where the second "then" sees that it already exists in the "available" stuff. -- - mapNF_Tc (newMethodFromName DoOrigin tc_ty) method_names `thenNF_Tc` \ insts -> + mapNF_Tc (tc_syn_name m_ty) + (zipEqual "tcDoStmts" monadNames method_names) `thenNF_Tc` \ stuff -> + let + (binds, ids, lies) = unzip3 stuff + in - returnTc (HsDo DoExpr stmts' - (map instToId insts) + returnTc (mkHsLet (andMonoBindList binds) $ + HsDo DoExpr stmts' ids res_ty src_loc, - stmts_lie `plusLIE` mkLIE insts) -\end{code} + stmts_lie `plusLIE` plusLIEs lies) + where + tc_syn_name :: TcType -> (Name,Name) -> TcM (TypecheckedMonoBinds, Id, LIE) + tc_syn_name m_ty (std_nm, usr_nm) + = tcSyntaxName DoOrigin m_ty std_nm usr_nm `thenTc` \ (expr, lie, expr_ty) -> + case expr of + HsVar v -> returnTc (EmptyMonoBinds, v, lie) + other -> tcGetUnique `thenTc` \ uniq -> + let + id = mkSysLocal FSLIT("syn") uniq expr_ty + in + returnTc (VarMonoBind id expr, id, lie) +\end{code} %************************************************************************ %* * @@ -1016,6 +1033,14 @@ exprSigCtxt expr = hang (ptext SLIT("When checking the type signature of the expression:")) 4 (ppr expr) +exprCtxt expr + = hang (ptext SLIT("In the expression:")) 4 (ppr expr) + +funAppCtxt fun arg arg_no + = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"), + quotes (ppr fun) <> text ", namely"]) + 4 (quotes (ppr arg)) + listCtxt expr = hang (ptext SLIT("In the list element:")) 4 (ppr expr) @@ -1025,14 +1050,6 @@ parrCtxt expr predCtxt expr = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr) -exprCtxt expr - = hang (ptext SLIT("In the expression:")) 4 (ppr expr) - -funAppCtxt fun arg arg_no - = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"), - quotes (ppr fun) <> text ", namely"]) - 4 (quotes (ppr arg)) - wrongArgsCtxt too_many_or_few fun args = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun) <+> ptext SLIT("is applied to") <+> text too_many_or_few