X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=649722118fda8357cd4e9fd2fe198cecab09ab2d;hb=77a8c0dbd5c5ad90fe483cb9ddc2b6ef36d3f4d8;hp=7aecdaaf81061d0ed2b46ca7a47a652039bbfbd0;hpb=3ca33229d4b9c1ed2829318631e73e748154f3ff;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 7aecdaa..6497221 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -9,12 +9,12 @@ module TcExpr ( tcApp, tcExpr, tcPolyExpr, tcId ) where #include "HsVersions.h" import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), - HsBinds(..), Stmt(..), StmtCtxt(..), + HsBinds(..), MonoBinds(..), Stmt(..), StmtCtxt(..), 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,48 @@ 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 ) + newTyVarTy, newTyVarTys, 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, - boxedTypeKind, mkArrowKind, + isSigmaTy, splitAlgTyConApp, splitAlgTyConApp_maybe, + boxedTypeKind, openTypeKind, 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 +71,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 +96,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 +128,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 +144,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 +169,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 +352,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)) @@ -373,7 +371,7 @@ tcMonoExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty tv_idxs | n_args == 0 = [] | otherwise = [1..n_args] in - mapNF_Tc (\ _ -> newTyVarTy_OpenKind) tv_idxs `thenNF_Tc` \ arg_tys -> + newTyVarTys (length tv_idxs) openTypeKind `thenNF_Tc` \ arg_tys -> tcMonoExprs args arg_tys `thenTc` \ (args', args_lie) -> -- The argument types can be unboxed or boxed; the result @@ -382,7 +380,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 +387,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 +459,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 +488,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 +557,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 +580,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 +694,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,22 +725,29 @@ 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 "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 (MonoBind dict_binds [] NonRecursive) expr' in - tcCheckIPBinds binds' types ips' `thenTc_` + else HsLet (mkMonoBind (revBinds dict_binds) [] NonRecursive) + expr' + in + tcCheckIPBinds binds' types ips `thenTc_` returnTc (HsWith expr'' binds', lie' `plusLIE` lie2) where isBound p = case ipName_maybe p of Just n -> n `elem` names Nothing -> False names = map fst binds + -- revBinds is used because tcSimplify outputs the bindings + -- out-of-order. it's not a problem elsewhere because these + -- bindings are normally used in a recursive let + -- ZZ probably need to find a better solution + revBinds (b1 `AndMonoBinds` b2) = + (revBinds b2) `AndMonoBinds` (revBinds b1) + revBinds b = b tcIPBinds ((name, expr) : binds) - = newTyVarTy_OpenKind `thenTc` \ ty -> + = newTyVarTy openTypeKind `thenTc` \ ty -> tcGetSrcLoc `thenTc` \ loc -> let id = ipToId name ty loc in tcMonoExpr expr ty `thenTc` \ (expr', lie) -> @@ -781,7 +782,7 @@ tcExpr_id id_expr = case id_expr of HsVar name -> tcId name `thenNF_Tc` \ stuff -> returnTc stuff - other -> newTyVarTy_OpenKind `thenNF_Tc` \ id_ty -> + other -> newTyVarTy openTypeKind `thenNF_Tc` \ id_ty -> tcMonoExpr id_expr id_ty `thenTc` \ (id_expr', lie_id) -> returnTc (id_expr', lie_id, id_ty) \end{code} @@ -890,11 +891,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. @@ -910,7 +911,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) -> @@ -977,54 +978,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 this type +2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty. -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. +For each binding field = value -4. Type check the value using tcArg, passing tau as the expected - argument 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 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