X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=1da69ecfbba86b833f7d9aabc5539f4fb8d8636a;hb=a7b95beb6077ff7c330e98c3d5b9268f33b21827;hp=1e210343333da367362a86561220b05f54d3e017;hpb=95581e0c3b2d4d6edd33fdd6e135aa3917072c4c;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 1e21034..1da69ec 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -9,10 +9,11 @@ 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 ( tcSubExp, tcGen, (<$>), @@ -21,9 +22,9 @@ import TcUnify ( tcSubExp, tcGen, (<$>), 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, @@ -37,7 +38,7 @@ 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, TcRhoType, TyVarDetails(VanillaTv), 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,7 +60,7 @@ import PrelNames ( cCallableClassName, enumFromName, enumFromThenName, enumFromToName, enumFromThenToName, enumFromToPName, enumFromThenToPName, - thenMName, failMName, returnMName, ioTyConName + thenMName, bindMName, failMName, returnMName, ioTyConName ) import Outputable import ListSetOps ( minusList ) @@ -372,7 +373,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 @@ -387,7 +388,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_` @@ -424,7 +425,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 @@ -443,15 +444,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 VanillaTv 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 @@ -491,42 +493,37 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty | tyvar `elemVarSet` common_tyvars = returnNF_Tc result_inst_ty -- Same as result 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) @@ -536,8 +533,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'), @@ -548,8 +545,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'), @@ -561,8 +558,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'), @@ -573,8 +570,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'), @@ -586,8 +583,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'), @@ -606,7 +603,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) -> @@ -616,7 +613,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 -> @@ -746,20 +743,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 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) @@ -777,6 +778,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. @@ -809,7 +819,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 -> @@ -818,14 +828,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, @@ -855,19 +865,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}