X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=2bb3060185cbfad70ae948cf93dab0e6ccbb9be6;hb=7bb069508f094825ca136ed97606651f3e093123;hp=100a838a7ba1f2e7094a70fc27d9d5fc1614654a;hpb=074d99bd864680f896b671fa354fcca6be77ae12;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 100a838..2bb3060 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -32,22 +32,21 @@ import TcEnv ( tcInstId, tcLookupValue, tcLookupClassByKey, tcLookupValueByKey, tcExtendGlobalTyVars, tcLookupValueMaybe, - tcLookupTyCon, tcLookupDataCon + tcLookupTyConByKey, tcLookupDataCon ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts ) import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt ) import TcPat ( badFieldCon ) import TcSimplify ( tcSimplify, tcSimplifyAndCheck, partitionPredsOfLIE ) +import TcImprove ( tcImprove ) import TcType ( TcType, TcTauType, tcInstTyVars, tcInstTcType, tcSplitRhoTy, newTyVarTy, newTyVarTy_OpenKind, zonkTcType ) import Class ( Class ) -import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType - ) -import Id ( idType, recordSelectorFieldLabel, - isRecordSelector, +import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon ) +import Id ( idType, recordSelectorFieldLabel, isRecordSelector, Id, mkVanillaId ) import DataCon ( dataConFieldLabels, dataConSig, @@ -60,11 +59,12 @@ import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkTyConApp, splitSigmaTy, splitRhoTy, isTauTy, tyVarsOfType, tyVarsOfTypes, - isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe, + isSigmaTy, splitAlgTyConApp, splitAlgTyConApp_maybe, boxedTypeKind, mkArrowKind, tidyOpenType ) -import Subst ( mkTopTyVarSubst, substClasses ) +import TyCon ( TyCon, tyConTyVars ) +import Subst ( mkTopTyVarSubst, substClasses, substTy ) import UsageSPUtils ( unannotTy ) import VarSet ( emptyVarSet, unionVarSet, elemVarSet, mkVarSet ) import TyCon ( tyConDataCons ) @@ -72,13 +72,11 @@ import TysPrim ( intPrimTy, charPrimTy, doublePrimTy, floatPrimTy, addrPrimTy ) import TysWiredIn ( boolTy, charTy, stringTy ) -import PrelInfo ( ioTyCon_NAME ) -import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy, - unifyUnboxedTupleTy ) +import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy ) import Unique ( cCallableClassKey, cReturnableClassKey, enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, enumFromThenToClassOpKey, - thenMClassOpKey, failMClassOpKey, returnMClassOpKey + thenMClassOpKey, failMClassOpKey, returnMClassOpKey, ioTyConKey ) import Outputable import Maybes ( maybeToBool, mapMaybe ) @@ -99,12 +97,12 @@ tcExpr :: RenamedHsExpr -- Expession to type check -> TcType -- Expected type (could be a polytpye) -> TcM s (TcExpr, LIE) -tcExpr expr ty | isForAllTy ty = -- Polymorphic case - tcPolyExpr expr ty `thenTc` \ (expr', lie, _, _, _) -> +tcExpr expr ty | isSigmaTy ty = -- Polymorphic case + tcPolyExpr expr ty `thenTc` \ (expr', lie, _, _, _) -> returnTc (expr', lie) - | otherwise = -- Monomorphic case - tcMonoExpr expr ty + | otherwise = -- Monomorphic case + tcMonoExpr expr ty \end{code} @@ -153,6 +151,7 @@ tcPolyExpr arg expected_arg_ty checkSigTyVars sig_tyvars free_tyvars `thenTc` \ zonked_sig_tyvars -> newDicts SignatureOrigin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) -> + tcImprove (sig_dicts `plusLIE` lie_arg) `thenTc_` -- ToDo: better origin tcSimplifyAndCheck (text "the type signature of an expression") @@ -358,7 +357,7 @@ tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty = -- Get the callable and returnable classes. tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass -> tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass -> - tcLookupTyCon ioTyCon_NAME `thenNF_Tc` \ ioTyCon -> + tcLookupTyConByKey ioTyConKey `thenNF_Tc` \ ioTyCon -> let new_arg_dict (arg, arg_ty) = newClassDicts (CCallOrigin (_UNPK_ lbl) (Just arg)) @@ -382,7 +381,6 @@ tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty newTyVarTy boxedTypeKind `thenNF_Tc` \ result_ty -> let io_result_ty = mkTyConApp ioTyCon [result_ty] - [ioDataCon] = tyConDataCons ioTyCon in unifyTauTy res_ty io_result_ty `thenTc_` @@ -462,21 +460,19 @@ tcMonoExpr in_expr@(ExplicitList exprs) res_ty -- Non-empty list = tcAddErrCtxt (listCtxt expr) $ tcMonoExpr expr elt_ty -tcMonoExpr (ExplicitTuple exprs boxed) res_ty - = (if boxed - then unifyTupleTy (length exprs) res_ty - else unifyUnboxedTupleTy (length exprs) res_ty - ) `thenTc` \ arg_tys -> +tcMonoExpr (ExplicitTuple exprs boxity) res_ty + = unifyTupleTy boxity (length exprs) res_ty `thenTc` \ arg_tys -> mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty) (exprs `zip` arg_tys) -- we know they're of equal length. `thenTc` \ (exprs', lies) -> - returnTc (ExplicitTuple exprs' boxed, plusLIEs lies) + returnTc (ExplicitTuple exprs' boxity, plusLIEs lies) tcMonoExpr expr@(RecordCon con_name rbinds) res_ty = tcAddErrCtxt (recordConCtxt expr) $ tcId con_name `thenNF_Tc` \ (con_expr, con_lie, con_tau) -> let (_, record_ty) = splitFunTys con_tau + (tycon, ty_args, _) = splitAlgTyConApp record_ty in ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) ) unifyTauTy res_ty record_ty `thenTc_` @@ -493,7 +489,7 @@ tcMonoExpr expr@(RecordCon con_name rbinds) res_ty else -- Typecheck the record bindings - tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) -> + tcRecordBinds tycon ty_args rbinds `thenTc` \ (rbinds', rbinds_lie) -> let missing_s_fields = missingStrictFields rbinds data_con @@ -566,8 +562,8 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty splitSigmaTy (idType sel_id) -- Selectors can be overloaded -- when the data type has a context Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector - (tycon, _, data_cons) = splitAlgTyConApp data_ty - (con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons) + (tycon, _, data_cons) = splitAlgTyConApp data_ty + (con_tyvars, _, _, _, _, _) = dataConSig (head data_cons) in tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) -> @@ -585,7 +581,7 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty result_record_ty = mkTyConApp tycon result_inst_tys in unifyTauTy res_ty result_record_ty `thenTc_` - tcRecordBinds result_record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) -> + tcRecordBinds tycon result_inst_tys rbinds `thenTc` \ (rbinds', rbinds_lie) -> -- STEP 4 -- Use the un-updated fields to find a vector of booleans saying @@ -701,7 +697,7 @@ tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty = tcSetErrCtxt (exprSigCtxt in_expr) $ tcHsSigType poly_ty `thenTc` \ sig_tc_ty -> - if not (isForAllTy sig_tc_ty) then + if not (isSigmaTy sig_tc_ty) then -- Easy case unifyTauTy sig_tc_ty res_ty `thenTc_` tcMonoExpr expr sig_tc_ty @@ -731,7 +727,6 @@ tcMonoExpr (HsWith expr binds) res_ty = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) -> tcIPBinds binds `thenTc` \ (binds', types, lie2) -> partitionPredsOfLIE isBound lie `thenTc` \ (ips, lie', dict_binds) -> - pprTrace "tcMonoExpr With" (ppr (ips, lie', dict_binds)) $ let expr'' = if nullMonoBinds dict_binds then expr' else HsLet (mkMonoBind (revBinds dict_binds) [] NonRecursive) @@ -897,11 +892,11 @@ tcId name tcLookupValueMaybe name `thenNF_Tc` \ maybe_local -> case maybe_local of - Just tc_id -> instantiate_it (OccurrenceOf tc_id) (HsVar tc_id) (unannotTy (idType tc_id)) + Just tc_id -> instantiate_it (OccurrenceOf tc_id) tc_id (unannotTy (idType tc_id)) Nothing -> tcLookupValue name `thenNF_Tc` \ id -> tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) -> - instantiate_it2 (OccurrenceOf id) (HsVar id) tyvars theta tau + instantiate_it2 (OccurrenceOf id) id tyvars theta tau where -- The instantiate_it loop runs round instantiating the Id. @@ -917,7 +912,7 @@ tcId name instantiate_it2 orig fun tyvars theta tau = if null theta then -- Is it overloaded? - returnNF_Tc (mkHsTyApp fun arg_tys, emptyLIE, tau) + returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau) else -- Yes, it's overloaded instOverloadedFun orig fun arg_tys theta tau `thenNF_Tc` \ (fun', lie1) -> @@ -984,54 +979,50 @@ tcDoStmts do_or_lc stmts src_loc res_ty Game plan for record bindings ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For each binding - field = value -1. look up "field", to find its selector Id, which must have type - forall a1..an. T a1 .. an -> tau - where tau is the type of the field. +1. Find the TyCon for the bindings, from the first field label. + +2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty. -2. Instantiate this type +For each binding field = value -3. Unify the (T a1 .. an) part with the "expected result type", which - is passed in. This checks that all the field labels come from the - same type. +3. Instantiate the field type (from the field label) using the type + envt from step 2. -4. Type check the value using tcArg, passing tau as the expected - argument type. +4 Type check the value using tcArg, passing the field type as + the expected argument type. This extends OK when the field types are universally quantified. -Actually, to save excessive creation of fresh type variables, -we \begin{code} tcRecordBinds - :: TcType -- Expected type of whole record + :: TyCon -- Type constructor for the record + -> [TcType] -- Args of this type constructor -> RenamedRecordBinds -> TcM s (TcRecordBinds, LIE) -tcRecordBinds expected_record_ty rbinds +tcRecordBinds tycon ty_args rbinds = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) -> returnTc (rbinds', plusLIEs lies) where - do_bind (field_label, rhs, pun_flag) - = tcLookupValue field_label `thenNF_Tc` \ sel_id -> + tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args + + do_bind (field_lbl_name, rhs, pun_flag) + = tcLookupValue field_lbl_name `thenNF_Tc` \ sel_id -> + let + field_lbl = recordSelectorFieldLabel sel_id + field_ty = substTy tenv (fieldLabelType field_lbl) + in ASSERT( isRecordSelector sel_id ) -- This lookup and assertion will surely succeed, because -- we check that the fields are indeed record selectors -- before calling tcRecordBinds + ASSERT2( fieldLabelTyCon field_lbl == tycon, ppr field_lbl ) + -- The caller of tcRecordBinds has already checked + -- that all the fields come from the same type - tcInstId sel_id `thenNF_Tc` \ (_, _, tau) -> + tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie, _, _, _) -> - -- Record selectors all have type - -- forall a1..an. T a1 .. an -> tau - ASSERT( maybeToBool (splitFunTy_maybe tau) ) - let - -- Selector must have type RecordType -> FieldType - Just (record_ty, field_ty) = splitFunTy_maybe tau - in - unifyTauTy expected_record_ty record_ty `thenTc_` - tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie, _, _, _) -> returnTc ((sel_id, rhs', pun_flag), lie) badFields rbinds data_con