X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=2bb3060185cbfad70ae948cf93dab0e6ccbb9be6;hb=495ef8bd9ef30bffe50ea399b91e3ba09646b59a;hp=6ac44b1235e6ad1ea723ca9ad6de05e44a1e2712;hpb=e87d56ce33f663da1c445f37e95c40d814caa384;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 6ac44b1..2bb3060 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -13,8 +13,8 @@ import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), mkMonoBind, nullMonoBinds ) import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds ) -import TcHsSyn ( TcExpr, TcRecordBinds, - mkHsTyApp, mkHsLet, maybeBoxedPrimType +import TcHsSyn ( TcExpr, TcRecordBinds, mkHsConApp, + mkHsTyApp, mkHsLet ) import TcMonad @@ -22,49 +22,49 @@ import BasicTypes ( RecFlag(..) ) import Inst ( Inst, InstOrigin(..), OverloadedLit(..), LIE, emptyLIE, unitLIE, consLIE, plusLIE, plusLIEs, - lieToList, listToLIE, tyVarsOfLIE, zonkLIE, + lieToList, listToLIE, newOverloadedLit, newMethod, newIPDict, instOverloadedFun, newDicts, newClassDicts, - partitionLIEbyMeth, getIPsOfLIE, instToId, ipToId + getIPsOfLIE, instToId, ipToId ) import TcBinds ( tcBindsAndThen ) import TcEnv ( tcInstId, tcLookupValue, tcLookupClassByKey, tcLookupValueByKey, tcExtendGlobalTyVars, tcLookupValueMaybe, - tcLookupTyCon, tcLookupDataCon + tcLookupTyConByKey, tcLookupDataCon ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts ) -import TcMonoType ( tcHsType, checkSigTyVars, sigCtxt ) +import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt ) import TcPat ( badFieldCon ) -import TcSimplify ( tcSimplify, tcSimplifyAndCheck ) +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, dataConId, +import DataCon ( dataConFieldLabels, dataConSig, dataConStrictMarks, StrictnessMark(..) ) import Name ( Name, getName ) import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, ipName_maybe, splitFunTy_maybe, splitFunTys, isNotUsgTy, - mkTyConApp, - splitForAllTys, splitRhoTy, + 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} @@ -131,6 +129,7 @@ tcPolyExpr arg expected_arg_ty tcInstTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) -> let (sig_theta, sig_tau) = splitRhoTy sig_rho + free_tyvars = tyVarsOfType expected_arg_ty in -- Type-check the arg and unify with expected type tcMonoExpr arg sig_tau `thenTc` \ (arg', lie_arg) -> @@ -146,12 +145,13 @@ tcPolyExpr arg expected_arg_ty -- Conclusion: include the free vars of the expected arg type in the -- list of "free vars" for the signature check. - tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) $ - tcAddErrCtxtM (sigCtxt sig_msg expected_arg_ty) $ + tcExtendGlobalTyVars free_tyvars $ + tcAddErrCtxtM (sigCtxt sig_msg sig_tyvars sig_theta sig_tau) $ - checkSigTyVars sig_tyvars `thenTc` \ zonked_sig_tyvars -> + 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") @@ -170,8 +170,7 @@ tcPolyExpr arg expected_arg_ty returnTc ( generalised_arg, free_insts, arg', sig_tau, lie_arg ) where - sig_msg ty = sep [ptext SLIT("In an expression with expected type:"), - nest 4 (ppr ty)] + sig_msg = ptext SLIT("When checking an expression type signature") \end{code} %************************************************************************ @@ -354,11 +353,11 @@ arg/result types); unify them with the args/result; and store them for later use. \begin{code} -tcMonoExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty +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 (CCall 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_` @@ -390,9 +388,7 @@ tcMonoExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty -- constraints on the argument and result types. mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s -> newClassDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) -> - returnTc (HsApp (HsVar (dataConId ioDataCon) `TyApp` [result_ty]) - (CCall lbl args' may_gc is_asm result_ty), - -- do the wrapping in the newtype constructor here + returnTc (HsCCall lbl args' may_gc is_asm io_result_ty, foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie) \end{code} @@ -464,27 +460,25 @@ 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 - -- Con is syntactically constrained to be a data constructor ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) ) unifyTauTy res_ty record_ty `thenTc_` -- Check that the record bindings match the constructor + -- con_name is syntactically constrained to be a data constructor tcLookupDataCon con_name `thenTc` \ (data_con, _, _) -> let bad_fields = badFields rbinds data_con @@ -495,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 @@ -564,11 +558,12 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty -- Figure out the tycon and data cons from the first field name let (Just sel_id : _) = maybe_sel_ids - (_, tau) = ASSERT( isNotUsgTy (idType sel_id) ) - splitForAllTys (idType sel_id) + (_, _, tau) = ASSERT( isNotUsgTy (idType sel_id) ) + 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, _) -> @@ -586,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 @@ -700,9 +695,9 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty \begin{code} tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty = tcSetErrCtxt (exprSigCtxt in_expr) $ - tcHsType poly_ty `thenTc` \ sig_tc_ty -> + 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,16 +726,13 @@ Implicit Parameter bindings. tcMonoExpr (HsWith expr binds) res_ty = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) -> tcIPBinds binds `thenTc` \ (binds', types, lie2) -> - partitionLIEbyMeth isBound lie `thenTc` \ (ips, lie') -> - zonkLIE ips `thenTc` \ ips' -> - tcSimplify (text "tcMonoExpr With") (tyVarsOfLIE ips') ips' - `thenTc` \ res@(_, dict_binds, _) -> + partitionPredsOfLIE isBound lie `thenTc` \ (ips, lie', dict_binds) -> let expr'' = if nullMonoBinds dict_binds then expr' else HsLet (mkMonoBind (revBinds dict_binds) [] NonRecursive) expr' in - tcCheckIPBinds binds' types ips' `thenTc_` + tcCheckIPBinds binds' types ips `thenTc_` returnTc (HsWith expr'' binds', lie' `plusLIE` lie2) where isBound p = case ipName_maybe p of @@ -900,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. @@ -920,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) -> @@ -987,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