X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=b84b4885e8c40fa20e0260f2c2e46c09fb52d45a;hb=75c431d16d01cb3b01f8d81d0520f43b4f9bac50;hp=b66730af067bfc3f02f5517ac6e5a7460094a6fa;hpb=5e3f005d3012472e422d4ffd7dca5c21a80fca80;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index b66730a..b84b488 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, (<$>), - unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy - ) +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, - newDicts, - instToId, tcInstId + newOverloadedLit, newMethodFromName, newIPDict, + newDicts, newMethodWithGivenTy, + instToId, tcInstCall, tcInstDataCon ) import TcBinds ( tcBindsAndThen ) import TcEnv ( tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe, @@ -33,38 +34,41 @@ import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts ) import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) import TcPat ( badFieldCon ) import TcSimplify ( tcSimplifyIPs ) -import TcMType ( tcInstTyVars, newTyVarTy, newTyVarTys, zonkTcType ) -import TcType ( TcType, TcSigmaType, TcPhiType, - tcSplitFunTys, tcSplitTyConApp, - isSigmaTy, mkFunTy, mkAppTy, mkTyConTy, +import TcMType ( tcInstTyVars, tcInstType, newHoleTyVarTy, zapToType, + newTyVarTy, newTyVarTys, zonkTcType, readHoleResult ) +import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv), + tcSplitFunTys, tcSplitTyConApp, mkTyVarTys, + isSigmaTy, mkFunTy, mkAppTy, mkFunTys, mkTyConApp, mkClassPred, tcFunArgTy, - tyVarsOfTypes, + tyVarsOfTypes, isLinearPred, liftedTypeKind, openTypeKind, mkArrowKind, tcSplitSigmaTy, tcTyConAppTyCon, 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 ( elemVarSet ) -import TysWiredIn ( boolTy, mkListTy, listTyCon ) +import VarSet ( emptyVarSet, elemVarSet ) +import TysWiredIn ( boolTy, mkListTy, mkPArrTy ) import PrelNames ( cCallableClassName, cReturnableClassName, enumFromName, enumFromThenName, enumFromToName, enumFromThenToName, - thenMName, failMName, returnMName, ioTyConName + enumFromToPName, enumFromThenToPName, + ioTyConName ) -import Outputable import ListSetOps ( minusList ) -import Util import CmdLineOpts import HscTypes ( TyThing(..) ) +import Util +import Outputable +import FastString \end{code} %************************************************************************ @@ -79,11 +83,17 @@ 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 | otherwise - = tcGen expected_ty (tcMonoExpr expr) `thenTc` \ (gen_fn, expr', lie) -> + = tcGen expected_ty emptyVarSet ( + tcMonoExpr expr + ) `thenTc` \ (gen_fn, expr', lie) -> returnTc (gen_fn <$> expr', lie) \end{code} @@ -96,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 @@ -113,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} @@ -126,11 +136,25 @@ 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) $ + = tcAddErrCtxt (exprSigCtxt in_expr) $ + tcHsSigType ExprSigCtxt poly_ty `thenTc` \ sig_tc_ty -> tcExpr expr sig_tc_ty `thenTc` \ (expr', lie1) -> - tcSub res_ty sig_tc_ty `thenTc` \ (co_fn, lie2) -> - returnTc (co_fn <$> expr', lie1 `plusLIE` lie2) + + -- 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 `thenNF_Tc` \ (inst_fn, lie2, inst_sig_ty) -> + 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} @@ -172,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 @@ -183,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: @@ -194,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} @@ -224,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 @@ -303,14 +327,17 @@ 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} \begin{code} -tcMonoExpr expr@(HsDo do_or_lc stmts src_loc) res_ty - = tcDoStmts do_or_lc stmts src_loc res_ty +tcMonoExpr expr@(HsDo do_or_lc stmts method_names _ src_loc) res_ty + = tcAddSrcLoc src_loc (tcDoStmts do_or_lc stmts method_names src_loc res_ty) \end{code} \begin{code} @@ -323,6 +350,15 @@ tcMonoExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list = tcAddErrCtxt (listCtxt expr) $ tcMonoExpr expr elt_ty +tcMonoExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty + = unifyPArrTy res_ty `thenTc` \ elt_ty -> + mapAndUnzipTc (tc_elt elt_ty) exprs `thenTc` \ (exprs', lies) -> + returnTc (ExplicitPArr elt_ty exprs', plusLIEs lies) + where + tc_elt elt_ty expr + = tcAddErrCtxt (parrCtxt expr) $ + tcMonoExpr expr elt_ty + tcMonoExpr (ExplicitTuple exprs boxity) res_ty = unifyTupleTy boxity (length exprs) res_ty `thenTc` \ arg_tys -> mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty) @@ -346,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 @@ -361,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_` @@ -398,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 @@ -417,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 @@ -463,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) @@ -510,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'), @@ -522,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'), @@ -535,12 +567,42 @@ 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'), lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` unitLIE eft) + +tcMonoExpr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty + = tcAddErrCtxt (parrSeqCtxt in_expr) $ + unifyPArrTy res_ty `thenTc` \ elt_ty -> + tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) -> + tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) -> + newMethodFromName (PArrSeqOrigin seq) + elt_ty enumFromToPName `thenNF_Tc` \ enum_from_to -> + + returnTc (PArrSeqOut (HsVar (instToId enum_from_to)) + (FromTo expr1' expr2'), + lie1 `plusLIE` lie2 `plusLIE` unitLIE enum_from_to) + +tcMonoExpr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty + = tcAddErrCtxt (parrSeqCtxt in_expr) $ + unifyPArrTy res_ty `thenTc` \ elt_ty -> + tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) -> + tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) -> + tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) -> + newMethodFromName (PArrSeqOrigin seq) + elt_ty enumFromThenToPName `thenNF_Tc` \ eft -> + + returnTc (PArrSeqOut (HsVar (instToId eft)) + (FromThenTo expr1' expr2' expr3'), + lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` unitLIE eft) + +tcMonoExpr (PArrSeqIn _) _ + = panic "TcExpr.tcMonoExpr: Infinite parallel array!" + -- the parser shouldn't have generated it and the renamer shouldn't have + -- let it through \end{code} %************************************************************************ @@ -550,7 +612,7 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty %************************************************************************ \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) -> @@ -560,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 -> @@ -590,19 +652,22 @@ 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) -> - -- Unify with expected result before type-checking the args - -- so that the info from res_ty percolates to expected_arg_tys - -- This is when we might detect a too-few args situation - tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) - (tcSub res_ty actual_result_ty) `thenTc` \ (co_fn, lie_res) -> - -- Now typecheck the args mapAndUnzipTc (tcArg fun) (zip3 args expected_arg_tys [1..]) `thenTc` \ (args', lie_args_s) -> + -- Unify with expected result after type-checking the args + -- so that the info from args percolates to actual_result_ty. + -- This is when we might detect a too-few args situation. + -- (One can think of cases when the opposite order would give + -- a better error message.) + tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) + (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) @@ -661,21 +726,90 @@ tcArg the_fun (arg, expected_arg_ty, arg_no) %* * %************************************************************************ +tcId instantiates an occurrence of an Id. +The instantiate_it loop runs round instantiating the Id. +It has to be a loop because we are now prepared to entertain +types like + f:: forall a. Eq a => forall b. Baz b => tau +We want to instantiate this to + f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)} + +The -fno-method-sharing flag controls what happens so far as the LIE +is concerned. The default case is that for an overloaded function we +generate a "method" Id, and add the Method Inst to the LIE. So you get +something like + f :: Num a => a -> a + f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x +If you specify -fno-method-sharing, the dictionary application +isn't shared, so we get + f :: Num a => a -> a + f = /\a (d:Num a) (x:a) -> (+) a d x x +This gets a bit less sharing, but + a) it's better for RULEs involving overloaded functions + b) perhaps fewer separated lambdas + \begin{code} tcId :: Name -> NF_TcM (TcExpr, LIE, TcType) tcId name -- Look up the Id and instantiate its type = tcLookupId name `thenNF_Tc` \ id -> - tcInstId id + case isDataConWrapId_maybe id of + Nothing -> loop (HsVar id) emptyLIE (idType id) + Just data_con -> inst_data_con id data_con + where + 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 (HsVar (instToId meth)) + (unitLIE meth `plusLIE` lie) tau + + loop fun lie fun_ty + | isSigmaTy fun_ty + = tcInstCall orig fun_ty `thenNF_Tc` \ (inst_fn, inst_lie, tau) -> + loop (inst_fn fun) (inst_lie `plusLIE` lie) tau + + | otherwise + = returnNF_Tc (fun, lie, fun_ty) + + want_method_inst fun_ty + | opt_NoMethodSharing = False + | otherwise = case tcSplitSigmaTy fun_ty of + (_,[],_) -> False -- Not overloaded + (_,theta,_) -> not (any isLinearPred theta) + -- This is a slight hack. + -- If f :: (%x :: T) => Int -> Int + -- Then if we have two separate calls, (f 3, f 4), we cannot + -- make a method constraint that then gets shared, thus: + -- let m = f %x in (m 3, m 4) + -- 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. +The expression can return a higher-ranked type, such as + (forall a. a->a) -> Int +so we must create a HoleTyVarTy to pass in as the expected tyvar. \begin{code} tcExpr_id :: RenamedHsExpr -> TcM (TcExpr, LIE, TcType) tcExpr_id (HsVar name) = tcId name -tcExpr_id expr = newTyVarTy openTypeKind `thenNF_Tc` \ id_ty -> - tcMonoExpr expr id_ty `thenTc` \ (expr', lie_id) -> - returnTc (expr', lie_id, id_ty) +tcExpr_id expr = newHoleTyVarTy `thenNF_Tc` \ id_ty -> + tcMonoExpr expr id_ty `thenTc` \ (expr', lie_id) -> + readHoleResult id_ty `thenTc` \ id_ty' -> + returnTc (expr', lie_id, id_ty') \end{code} @@ -686,26 +820,30 @@ tcExpr_id expr = newTyVarTy openTypeKind `thenNF_Tc` \ id_ty -> %************************************************************************ \begin{code} -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) ) - tcAddSrcLoc src_loc $ - - -- If it's a comprehension we're dealing with, - -- force it to be a list comprehension. - -- (as of Haskell 98, monad comprehensions are no more.) - (case do_or_lc of - ListComp -> unifyListTy res_ty `thenTc` \ elt_ty -> - returnNF_Tc (mkTyConTy listTyCon, (mkListTy, elt_ty)) - - _ -> newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenNF_Tc` \ m_ty -> - newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty -> - unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenTc_` - returnNF_Tc (m_ty, (mkAppTy m_ty, elt_ty)) - ) `thenNF_Tc` \ (tc_ty, m_ty) -> - - tcStmts (DoCtxt do_or_lc) m_ty stmts `thenTc` \ (stmts', stmts_lie) -> +tcDoStmts PArrComp stmts method_names src_loc res_ty + = unifyPArrTy res_ty `thenTc` \elt_ty -> + tcStmts (DoCtxt PArrComp) + (mkPArrTy, elt_ty) stmts `thenTc` \(stmts', stmts_lie) -> + returnTc (HsDo PArrComp stmts' + [] -- Unused + res_ty src_loc, + stmts_lie) + +tcDoStmts ListComp stmts method_names src_loc res_ty + = unifyListTy res_ty `thenTc` \ elt_ty -> + tcStmts (DoCtxt ListComp) + (mkListTy, elt_ty) stmts `thenTc` \ (stmts', stmts_lie) -> + returnTc (HsDo ListComp stmts' + [] -- Unused + res_ty src_loc, + stmts_lie) + +tcDoStmts DoExpr stmts method_names src_loc res_ty + = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenNF_Tc` \ tc_ty -> + newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty -> + unifyTauTy res_ty (mkAppTy tc_ty elt_ty) `thenTc_` + + tcStmts (DoCtxt DoExpr) (mkAppTy tc_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, @@ -715,19 +853,12 @@ 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 - returnTc (HsDoOut do_or_lc stmts' - (instToId return_inst) (instToId then_inst) (instToId fail_inst) - res_ty src_loc, - stmts_lie `plusLIE` monad_lie) + mapNF_Tc (newMethodFromName DoOrigin tc_ty) method_names `thenNF_Tc` \ insts -> + + returnTc (HsDo DoExpr stmts' + (map instToId insts) + res_ty src_loc, + stmts_lie `plusLIE` mkLIE insts) \end{code} @@ -849,7 +980,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) @@ -872,6 +1003,9 @@ Boring and alphabetical: arithSeqCtxt expr = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr) +parrSeqCtxt expr + = hang (ptext SLIT("In a parallel array sequence:")) 4 (ppr expr) + caseCtxt expr = hang (ptext SLIT("In the case expression:")) 4 (ppr expr) @@ -879,12 +1013,15 @@ caseScrutCtxt expr = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr) exprSigCtxt expr - = hang (ptext SLIT("In an expression with a type signature:")) + = hang (ptext SLIT("When checking the type signature of the expression:")) 4 (ppr expr) listCtxt expr = hang (ptext SLIT("In the list element:")) 4 (ppr expr) +parrCtxt expr + = hang (ptext SLIT("In the parallel array element:")) 4 (ppr expr) + predCtxt expr = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)