X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=e6a3d850e2101ac0f7930eb98bd6646430c364be;hb=883a8fc6a85243015937ae93c3f569f82582c93e;hp=252d995669e0a0b76d384f53b6d7a86493551c42;hpb=469c3333ae5954cee58cdb1575b41fb1a3c34f06;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 252d995..e6a3d85 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -9,21 +9,22 @@ module TcExpr ( tcExpr, tcMonoExpr, tcId ) where #include "HsVersions.h" import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), - HsMatchContext(..), HsDoContext(..), mkMonoBind + HsMatchContext(..), HsDoContext(..), + mkMonoBind ) import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds ) -import TcHsSyn ( TcExpr, TcRecordBinds, simpleHsLitTy ) +import TcHsSyn ( TcExpr, TcRecordBinds, simpleHsLitTy, mkHsDictApp, mkHsTyApp ) import TcMonad -import TcUnify ( tcSub, tcGen, (<$>), +import TcUnify ( tcSubExp, tcGen, (<$>), unifyTauTy, unifyFunTy, unifyListTy, unifyPArrTy, unifyTupleTy ) import BasicTypes ( RecFlag(..), isMarkedStrict ) import Inst ( InstOrigin(..), LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs, - newOverloadedLit, newMethod, newIPDict, + newOverloadedLit, newMethodFromName, newIPDict, newDicts, newMethodWithGivenTy, - instToId, tcInstCall + instToId, tcInstCall, tcInstDataCon ) import TcBinds ( tcBindsAndThen ) import TcEnv ( tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe, @@ -33,11 +34,11 @@ import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts ) import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) import TcPat ( badFieldCon ) import TcSimplify ( tcSimplifyIPs ) -import TcMType ( tcInstTyVars, tcInstType, newHoleTyVarTy, - newTyVarTy, newTyVarTys, zonkTcType ) -import TcType ( TcType, TcSigmaType, TcPhiType, +import TcMType ( tcInstTyVars, tcInstType, newHoleTyVarTy, zapToType, + newTyVarTy, newTyVarTys, zonkTcType, readHoleResult ) +import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv), tcSplitFunTys, tcSplitTyConApp, mkTyVarTys, - isSigmaTy, mkFunTy, mkAppTy, mkTyConTy, + isSigmaTy, mkFunTy, mkAppTy, mkTyConTy, mkFunTys, mkTyConApp, mkClassPred, tcFunArgTy, tyVarsOfTypes, isLinearPred, liftedTypeKind, openTypeKind, mkArrowKind, @@ -45,12 +46,12 @@ import TcType ( TcType, TcSigmaType, TcPhiType, tidyOpenType ) import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon ) -import Id ( idType, recordSelectorFieldLabel, isRecordSelector ) +import Id ( idType, recordSelectorFieldLabel, isRecordSelector, isDataConWrapId_maybe ) import DataCon ( dataConFieldLabels, dataConSig, dataConStrictMarks ) import Name ( Name ) -import TyCon ( TyCon, tyConTyVars, isAlgTyCon, tyConDataCons ) +import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) import VarSet ( emptyVarSet, elemVarSet ) import TysWiredIn ( boolTy, mkListTy, mkPArrTy, listTyCon, parrTyCon ) @@ -59,14 +60,15 @@ import PrelNames ( cCallableClassName, enumFromName, enumFromThenName, enumFromToName, enumFromThenToName, enumFromToPName, enumFromThenToPName, - thenMName, failMName, returnMName, ioTyConName + thenMName, bindMName, failMName, returnMName, ioTyConName ) -import Outputable import ListSetOps ( minusList ) -import Util import CmdLineOpts import HscTypes ( TyThing(..) ) +import Util +import Outputable +import FastString \end{code} %************************************************************************ @@ -81,6 +83,10 @@ tcExpr :: RenamedHsExpr -- Expession to type check -> TcM (TcExpr, LIE) -- Generalised expr with expected type, and LIE tcExpr expr expected_ty + = traceTc (text "tcExpr" <+> (ppr expected_ty $$ ppr expr)) `thenNF_Tc_` + tc_expr' expr expected_ty + +tc_expr' expr expected_ty | not (isSigmaTy expected_ty) -- Monomorphic case = tcMonoExpr expr expected_ty @@ -100,14 +106,14 @@ tcExpr expr expected_ty \begin{code} tcMonoExpr :: RenamedHsExpr -- Expession to type check - -> TcPhiType -- Expected type (could be a type variable) + -> TcRhoType -- Expected type (could be a type variable) -- Definitely no foralls at the top -- Can be a 'hole'. -> TcM (TcExpr, LIE) tcMonoExpr (HsVar name) res_ty = tcId name `thenNF_Tc` \ (expr', lie1, id_ty) -> - tcSub res_ty id_ty `thenTc` \ (co_fn, lie2) -> + tcSubExp res_ty id_ty `thenTc` \ (co_fn, lie2) -> returnTc (co_fn <$> expr', lie1 `plusLIE` lie2) tcMonoExpr (HsIPVar ip) res_ty @@ -117,7 +123,7 @@ tcMonoExpr (HsIPVar ip) res_ty -- be a tau-type.) newTyVarTy openTypeKind `thenNF_Tc` \ ip_ty -> newIPDict (IPOcc ip) ip ip_ty `thenNF_Tc` \ (ip', inst) -> - tcSub res_ty ip_ty `thenTc` \ (co_fn, lie) -> + tcSubExp res_ty ip_ty `thenTc` \ (co_fn, lie) -> returnNF_Tc (co_fn <$> HsIPVar ip', lie `plusLIE` unitLIE inst) \end{code} @@ -138,9 +144,17 @@ tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty -- 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) -> - tcSub res_ty inst_sig_ty `thenTc` \ (co_fn, lie3) -> + tcSubExp res_ty inst_sig_ty `thenTc` \ (co_fn, lie3) -> returnTc (co_fn <$> inst_fn expr', lie1 `plusLIE` lie2 `plusLIE` lie3) + +tcMonoExpr (HsType ty) res_ty + = failWithTc (text "Can't handle type argument:" <+> ppr ty) + -- This is the syntax for type applications that I was planning + -- but there are difficulties (e.g. what order for type args) + -- so it's not enabled yet. + -- Can't eliminate it altogether from the parser, because the + -- same parser parses *patterns*. \end{code} @@ -182,7 +196,7 @@ tcMonoExpr in_expr@(SectionL arg1 op) res_ty split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) -> tcArg op (arg1, arg1_ty, 1) `thenTc` \ (arg1',lie2) -> tcAddErrCtxt (exprCtxt in_expr) $ - tcSub res_ty (mkFunTy arg2_ty op_res_ty) `thenTc` \ (co_fn, lie3) -> + tcSubExp res_ty (mkFunTy arg2_ty op_res_ty) `thenTc` \ (co_fn, lie3) -> returnTc (co_fn <$> SectionL arg1' op', lie1 `plusLIE` lie2 `plusLIE` lie3) -- Right sections, equivalent to \ x -> x op expr, or @@ -193,7 +207,7 @@ tcMonoExpr in_expr@(SectionR op arg2) res_ty split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) -> tcArg op (arg2, arg2_ty, 2) `thenTc` \ (arg2',lie2) -> tcAddErrCtxt (exprCtxt in_expr) $ - tcSub res_ty (mkFunTy arg1_ty op_res_ty) `thenTc` \ (co_fn, lie3) -> + tcSubExp res_ty (mkFunTy arg1_ty op_res_ty) `thenTc` \ (co_fn, lie3) -> returnTc (co_fn <$> SectionR op' arg2', lie1 `plusLIE` lie2 `plusLIE` lie3) -- equivalent to (op e1) e2: @@ -204,7 +218,7 @@ tcMonoExpr in_expr@(OpApp arg1 op fix arg2) res_ty tcArg op (arg1, arg1_ty, 1) `thenTc` \ (arg1',lie2a) -> tcArg op (arg2, arg2_ty, 2) `thenTc` \ (arg2',lie2b) -> tcAddErrCtxt (exprCtxt in_expr) $ - tcSub res_ty op_res_ty `thenTc` \ (co_fn, lie3) -> + tcSubExp res_ty op_res_ty `thenTc` \ (co_fn, lie3) -> returnTc (OpApp arg1' op' fix arg2', lie1 `plusLIE` lie2a `plusLIE` lie2b `plusLIE` lie3) \end{code} @@ -234,11 +248,11 @@ tcMonoExpr e0@(HsCCall lbl args may_gc is_casm ignored_fake_result_ty) res_ty tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon -> let new_arg_dict (arg, arg_ty) - = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg)) + = newDicts (CCallOrigin (unpackFS lbl) (Just arg)) [mkClassPred cCallableClass [arg_ty]] `thenNF_Tc` \ arg_dicts -> returnNF_Tc arg_dicts -- Actually a singleton bag - result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -} + result_origin = CCallOrigin (unpackFS lbl) Nothing {- Not an arg -} in -- Arguments @@ -313,8 +327,11 @@ tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty tcAddErrCtxt (predCtxt pred) ( tcMonoExpr pred boolTy ) `thenTc` \ (pred',lie1) -> - tcMonoExpr b1 res_ty `thenTc` \ (b1',lie2) -> - tcMonoExpr b2 res_ty `thenTc` \ (b2',lie3) -> + zapToType res_ty `thenTc` \ res_ty' -> + -- C.f. the call to zapToType in TcMatches.tcMatches + + tcMonoExpr b1 res_ty' `thenTc` \ (b1',lie2) -> + tcMonoExpr b2 res_ty' `thenTc` \ (b2',lie3) -> returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3)) \end{code} @@ -365,7 +382,7 @@ tcMonoExpr expr@(RecordCon con_name rbinds) res_ty let bad_fields = badFields rbinds data_con in - if not (null bad_fields) then + if notNull bad_fields then mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields `thenNF_Tc_` failTc -- Fail now, because tcRecordBinds will crash on a bad field else @@ -380,7 +397,7 @@ tcMonoExpr expr@(RecordCon con_name rbinds) res_ty (mapNF_Tc (addErrTc . missingStrictFieldCon con_name) missing_s_fields `thenNF_Tc_` returnNF_Tc ()) `thenNF_Tc_` doptsTc Opt_WarnMissingFields `thenNF_Tc` \ warn -> - checkTcM (not (warn && not (null missing_fields))) + checkTcM (not (warn && notNull missing_fields)) (mapNF_Tc ((warnTc True) . missingFieldCon con_name) missing_fields `thenNF_Tc_` returnNF_Tc ()) `thenNF_Tc_` @@ -417,7 +434,7 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty -- STEP 0 -- Check that the field names are really field names - ASSERT( not (null rbinds) ) + ASSERT( notNull rbinds ) let field_names = [field_name | (field_name, _, _) <- rbinds] in @@ -436,15 +453,16 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty -- Figure out the tycon and data cons from the first field name let -- It's OK to use the non-tc splitters here (for a selector) - (Just (AnId sel_id) : _) = maybe_sel_ids - (_, _, tau) = tcSplitSigmaTy (idType sel_id) -- Selectors can be overloaded - -- when the data type has a context - data_ty = tcFunArgTy tau -- Must succeed since sel_id is a selector - tycon = tcTyConAppTyCon data_ty - data_cons = tyConDataCons tycon - (con_tyvars, _, _, _, _, _) = dataConSig (head data_cons) + (Just (AnId sel_id) : _) = maybe_sel_ids + + (_, _, tau) = tcSplitSigmaTy (idType sel_id) -- Selectors can be overloaded + -- when the data type has a context + data_ty = tcFunArgTy tau -- Must succeed since sel_id is a selector + tycon = tcTyConAppTyCon data_ty + data_cons = tyConDataCons tycon + tycon_tyvars = tyConTyVars tycon -- The data cons use the same type vars in - tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) -> + tcInstTyVars VanillaTv tycon_tyvars `thenNF_Tc` \ (_, result_inst_tys, inst_env) -> -- STEP 2 -- Check that at least one constructor has all the named fields @@ -482,44 +500,39 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty mk_inst_ty (tyvar, result_inst_ty) | tyvar `elemVarSet` common_tyvars = returnNF_Tc result_inst_ty -- Same as result type - | otherwise = newTyVarTy liftedTypeKind -- Fresh type + | otherwise = newTyVarTy liftedTypeKind -- Fresh type in - mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys) `thenNF_Tc` \ inst_tys -> + mapNF_Tc mk_inst_ty (zip tycon_tyvars result_inst_tys) `thenNF_Tc` \ inst_tys -> -- STEP 5 -- Typecheck the expression to be updated let record_ty = mkTyConApp tycon inst_tys in - tcMonoExpr record_expr record_ty `thenTc` \ (record_expr', record_lie) -> + tcMonoExpr record_expr record_ty `thenTc` \ (record_expr', record_lie) -> -- STEP 6 -- Figure out the LIE we need. We have to generate some -- dictionaries for the data type context, since we are going to - -- do some construction. + -- do pattern matching over the data cons. -- - -- What dictionaries do we need? For the moment we assume that all - -- data constructors have the same context, and grab it from the first - -- constructor. If they have varying contexts then we'd have to - -- union the ones that could participate in the update. + -- What dictionaries do we need? + -- We just take the context of the type constructor let - (tyvars, theta, _, _, _, _) = dataConSig (head data_cons) - inst_env = mkTopTyVarSubst tyvars result_inst_tys - theta' = substTheta inst_env theta + theta' = substTheta inst_env (tyConTheta tycon) in newDicts RecordUpdOrigin theta' `thenNF_Tc` \ dicts -> -- Phew! - returnTc (RecordUpdOut record_expr' record_ty result_record_ty (map instToId dicts) rbinds', + returnTc (RecordUpdOut record_expr' record_ty result_record_ty rbinds', mkLIE dicts `plusLIE` record_lie `plusLIE` rbinds_lie) tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty = unifyListTy res_ty `thenTc` \ elt_ty -> tcMonoExpr expr elt_ty `thenTc` \ (expr', lie1) -> - tcLookupGlobalId enumFromName `thenNF_Tc` \ sel_id -> - newMethod (ArithSeqOrigin seq) - sel_id [elt_ty] `thenNF_Tc` \ enum_from -> + newMethodFromName (ArithSeqOrigin seq) + elt_ty enumFromName `thenNF_Tc` \ enum_from -> returnTc (ArithSeqOut (HsVar (instToId enum_from)) (From expr'), lie1 `plusLIE` unitLIE enum_from) @@ -529,8 +542,8 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty unifyListTy res_ty `thenTc` \ elt_ty -> tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) -> tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) -> - tcLookupGlobalId enumFromThenName `thenNF_Tc` \ sel_id -> - newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ enum_from_then -> + newMethodFromName (ArithSeqOrigin seq) + elt_ty enumFromThenName `thenNF_Tc` \ enum_from_then -> returnTc (ArithSeqOut (HsVar (instToId enum_from_then)) (FromThen expr1' expr2'), @@ -541,8 +554,8 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty unifyListTy res_ty `thenTc` \ elt_ty -> tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) -> tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) -> - tcLookupGlobalId enumFromToName `thenNF_Tc` \ sel_id -> - newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ enum_from_to -> + newMethodFromName (ArithSeqOrigin seq) + elt_ty enumFromToName `thenNF_Tc` \ enum_from_to -> returnTc (ArithSeqOut (HsVar (instToId enum_from_to)) (FromTo expr1' expr2'), @@ -554,8 +567,8 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) -> tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) -> tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) -> - tcLookupGlobalId enumFromThenToName `thenNF_Tc` \ sel_id -> - newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ eft -> + newMethodFromName (ArithSeqOrigin seq) + elt_ty enumFromThenToName `thenNF_Tc` \ eft -> returnTc (ArithSeqOut (HsVar (instToId eft)) (FromThenTo expr1' expr2' expr3'), @@ -566,8 +579,8 @@ tcMonoExpr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty unifyPArrTy res_ty `thenTc` \ elt_ty -> tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) -> tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) -> - tcLookupGlobalId enumFromToPName `thenNF_Tc` \ sel_id -> - newMethod (PArrSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ enum_from_to -> + newMethodFromName (PArrSeqOrigin seq) + elt_ty enumFromToPName `thenNF_Tc` \ enum_from_to -> returnTc (PArrSeqOut (HsVar (instToId enum_from_to)) (FromTo expr1' expr2'), @@ -579,8 +592,8 @@ tcMonoExpr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) -> tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) -> tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) -> - tcLookupGlobalId enumFromThenToPName `thenNF_Tc` \ sel_id -> - newMethod (PArrSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ eft -> + newMethodFromName (PArrSeqOrigin seq) + elt_ty enumFromThenToPName `thenNF_Tc` \ eft -> returnTc (PArrSeqOut (HsVar (instToId eft)) (FromThenTo expr1' expr2' expr3'), @@ -599,7 +612,7 @@ tcMonoExpr (PArrSeqIn _) _ %************************************************************************ \begin{code} -tcMonoExpr (HsWith expr binds) res_ty +tcMonoExpr (HsWith expr binds is_with) res_ty = tcMonoExpr expr res_ty `thenTc` \ (expr', expr_lie) -> mapAndUnzip3Tc tcIPBind binds `thenTc` \ (avail_ips, binds', bind_lies) -> @@ -609,7 +622,7 @@ tcMonoExpr (HsWith expr binds) res_ty let expr'' = HsLet (mkMonoBind dict_binds [] Recursive) expr' in - returnTc (HsWith expr'' binds', expr_lie' `plusLIE` plusLIEs bind_lies) + returnTc (HsWith expr'' binds' is_with, expr_lie' `plusLIE` plusLIEs bind_lies) tcIPBind (ip, expr) = newTyVarTy openTypeKind `thenTc` \ ty -> @@ -639,6 +652,7 @@ tcApp fun args res_ty tcExpr_id fun `thenTc` \ (fun', lie_fun, fun_ty) -> tcAddErrCtxt (wrongArgsCtxt "too many" fun args) ( + traceTc (text "tcApp" <+> (ppr fun $$ ppr fun_ty)) `thenNF_Tc_` split_fun_ty fun_ty (length args) ) `thenTc` \ (expected_arg_tys, actual_result_ty) -> @@ -652,7 +666,7 @@ tcApp fun args res_ty -- (One can think of cases when the opposite order would give -- a better error message.) tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) - (tcSub res_ty actual_result_ty) `thenTc` \ (co_fn, lie_res) -> + (tcSubExp res_ty actual_result_ty) `thenTc` \ (co_fn, lie_res) -> returnTc (co_fn <$> foldl HsApp fun' args', lie_res `plusLIE` lie_fun `plusLIE` plusLIEs lie_args_s) @@ -738,20 +752,24 @@ This gets a bit less sharing, but tcId :: Name -> NF_TcM (TcExpr, LIE, TcType) tcId name -- Look up the Id and instantiate its type = tcLookupId name `thenNF_Tc` \ id -> - loop (OccurrenceOf id) (HsVar id) emptyLIE (idType id) + case isDataConWrapId_maybe id of + Nothing -> loop (HsVar id) emptyLIE (idType id) + Just data_con -> inst_data_con id data_con where - loop orig (HsVar fun_id) lie fun_ty + orig = OccurrenceOf name + + loop (HsVar fun_id) lie fun_ty | want_method_inst fun_ty - = tcInstType fun_ty `thenNF_Tc` \ (tyvars, theta, tau) -> + = tcInstType VanillaTv fun_ty `thenNF_Tc` \ (tyvars, theta, tau) -> newMethodWithGivenTy orig fun_id (mkTyVarTys tyvars) theta tau `thenNF_Tc` \ meth -> - loop orig (HsVar (instToId meth)) + loop (HsVar (instToId meth)) (unitLIE meth `plusLIE` lie) tau - loop orig fun lie fun_ty + loop fun lie fun_ty | isSigmaTy fun_ty = tcInstCall orig fun_ty `thenNF_Tc` \ (inst_fn, inst_lie, tau) -> - loop orig (inst_fn fun) (inst_lie `plusLIE` lie) tau + loop (inst_fn fun) (inst_lie `plusLIE` lie) tau | otherwise = returnNF_Tc (fun, lie, fun_ty) @@ -769,6 +787,15 @@ tcId name -- Look up the Id and instantiate its type -- because that loses the linearity of the constraint. -- The simplest thing to do is never to construct a method constraint -- in the first place that has a linear implicit parameter in it. + + -- We treat data constructors differently, because we have to generate + -- constraints for their silly theta, which no longer appears in + -- the type of dataConWrapId. It's dual to TcPat.tcConstructor + inst_data_con id data_con + = tcInstDataCon orig data_con `thenNF_Tc` \ (ty_args, ex_dicts, arg_tys, result_ty, stupid_lie, ex_lie, _) -> + returnNF_Tc (mkHsDictApp (mkHsTyApp (HsVar id) ty_args) ex_dicts, + stupid_lie `plusLIE` ex_lie, + mkFunTys arg_tys result_ty) \end{code} Typecheck expression which in most cases will be an Id. @@ -781,7 +808,8 @@ tcExpr_id :: RenamedHsExpr -> TcM (TcExpr, LIE, TcType) tcExpr_id (HsVar name) = tcId name tcExpr_id expr = newHoleTyVarTy `thenNF_Tc` \ id_ty -> tcMonoExpr expr id_ty `thenTc` \ (expr', lie_id) -> - returnTc (expr', lie_id, id_ty) + readHoleResult id_ty `thenTc` \ id_ty' -> + returnTc (expr', lie_id, id_ty') \end{code} @@ -800,7 +828,7 @@ tcExpr_id expr = newHoleTyVarTy `thenNF_Tc` \ id_ty -> -- tcDoStmts PArrComp stmts src_loc res_ty = - ASSERT( not (null stmts) ) + ASSERT( notNull stmts ) tcAddSrcLoc src_loc $ unifyPArrTy res_ty `thenTc` \elt_ty -> @@ -809,14 +837,14 @@ tcDoStmts PArrComp stmts src_loc res_ty in tcStmts (DoCtxt PArrComp) m_ty stmts `thenTc` \(stmts', stmts_lie) -> returnTc (HsDoOut PArrComp stmts' - undefined undefined undefined -- don't touch! + undefined -- don't touch! res_ty src_loc, stmts_lie) tcDoStmts do_or_lc stmts src_loc res_ty = -- get the Monad and MonadZero classes -- create type consisting of a fresh monad tyvar - ASSERT( not (null stmts) ) + ASSERT( notNull stmts ) tcAddSrcLoc src_loc $ -- If it's a comprehension we're dealing with, @@ -846,19 +874,13 @@ tcDoStmts do_or_lc stmts src_loc res_ty -- then = then -- where the second "then" sees that it already exists in the "available" stuff. -- - tcLookupGlobalId returnMName `thenNF_Tc` \ return_sel_id -> - tcLookupGlobalId thenMName `thenNF_Tc` \ then_sel_id -> - tcLookupGlobalId failMName `thenNF_Tc` \ fail_sel_id -> - newMethod DoOrigin return_sel_id [tc_ty] `thenNF_Tc` \ return_inst -> - newMethod DoOrigin then_sel_id [tc_ty] `thenNF_Tc` \ then_inst -> - newMethod DoOrigin fail_sel_id [tc_ty] `thenNF_Tc` \ fail_inst -> - let - monad_lie = mkLIE [return_inst, then_inst, fail_inst] - in + mapNF_Tc (newMethodFromName DoOrigin tc_ty) + [returnMName, failMName, bindMName, thenMName] `thenNF_Tc` \ insts -> + returnTc (HsDoOut do_or_lc stmts' - (instToId return_inst) (instToId then_inst) (instToId fail_inst) + (map instToId insts) res_ty src_loc, - stmts_lie `plusLIE` monad_lie) + stmts_lie `plusLIE` mkLIE insts) \end{code} @@ -980,7 +1002,7 @@ Overloaded literals. tcLit :: HsLit -> TcType -> TcM (TcExpr, LIE) tcLit (HsLitLit s _) res_ty = tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass -> - newDicts (LitLitOrigin (_UNPK_ s)) + newDicts (LitLitOrigin (unpackFS s)) [mkClassPred cCallableClass [res_ty]] `thenNF_Tc` \ dicts -> returnTc (HsLit (HsLitLit s res_ty), mkLIE dicts)