X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=a26a106e8461af01bbb60f405627e50128404a36;hb=ca49225cd41123ab6ce229040a93cc4b993b190a;hp=37084365eccce809dc06265aa2e82e08595f5206;hpb=872f7e822cb83692afa808509b4f2a6b4343fb2c;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 3708436..a26a106 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -31,7 +31,7 @@ import TcUnify ( Expected(..), tcInfer, zapExpectedType, zapExpectedTo, import BasicTypes ( isMarkedStrict ) import Inst ( tcOverloadedLit, newMethodFromName, newIPDict, newDicts, newMethodWithGivenTy, tcInstStupidTheta, tcInstCall ) -import TcBinds ( tcBindsAndThen ) +import TcBinds ( tcLocalBinds ) import TcEnv ( tcLookup, tcLookupId, tcLookupDataCon, tcLookupGlobalId ) @@ -40,20 +40,19 @@ import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMa import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) import TcPat ( badFieldCon, refineTyVars ) import TcMType ( tcInstTyVars, tcInstType, newTyFlexiVarTy, zonkTcType ) -import TcType ( Type, TcTyVar, TcType, TcSigmaType, TcRhoType, - tcSplitFunTys, tcSplitTyConApp, mkTyVarTys, +import TcType ( TcTyVar, TcType, TcSigmaType, TcRhoType, + tcSplitFunTys, mkTyVarTys, isSigmaTy, mkFunTy, mkTyConApp, tyVarsOfTypes, isLinearPred, tcSplitSigmaTy, tidyOpenType ) import Kind ( openTypeKind, liftedTypeKind, argTypeKind ) -import Id ( idType, recordSelectorFieldLabel, isRecordSelector ) +import Id ( idType, recordSelectorFieldLabel, isRecordSelector, isNaughtyRecordSelector ) import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, - dataConWrapId ) + dataConWrapId, isVanillaDataCon, dataConTyVars, dataConOrigArgTys ) import Name ( Name ) -import TyCon ( TyCon, FieldLabel, tyConTyVars, tyConStupidTheta, - tyConDataCons, tyConFields ) -import Type ( zipTopTvSubst, substTheta, substTy ) +import TyCon ( FieldLabel, tyConStupidTheta, tyConDataCons ) +import Type ( substTheta, substTy ) import Var ( tyVarKind ) import VarSet ( emptyVarSet, elemVarSet ) import TysWiredIn ( boolTy, parrTyCon, tupleTyCon ) @@ -61,17 +60,18 @@ import PrelNames ( enumFromName, enumFromThenName, enumFromToName, enumFromThenToName, enumFromToPName, enumFromThenToPName, negateName ) -import ListSetOps ( minusList ) import DynFlags import StaticFlags ( opt_NoMethodSharing ) import HscTypes ( TyThing(..) ) import SrcLoc ( Located(..), unLoc, getLoc ) import Util +import ListSetOps ( assocMaybe ) +import Maybes ( catMaybes ) import Outputable import FastString #ifdef DEBUG -import TyCon ( isAlgTyCon ) +import TyCon ( tyConArity ) #endif \end{code} @@ -88,7 +88,7 @@ tcCheckSigma :: LHsExpr Name -- Expession to type check -> TcM (LHsExpr TcId) -- Generalised expr with expected type tcCheckSigma expr expected_ty - = traceTc (text "tcExpr" <+> (ppr expected_ty $$ ppr expr)) `thenM_` + = -- traceTc (text "tcExpr" <+> (ppr expected_ty $$ ppr expr)) `thenM_` tc_expr' expr expected_ty tc_expr' expr sigma_ty @@ -240,7 +240,7 @@ a type error will occur if they aren't. tcExpr in_expr@(SectionL arg1 op) res_ty = tcInferRho op `thenM` \ (op', op_ty) -> - unifyFunTys 2 op_ty {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) -> + unifyInfixTy op in_expr op_ty `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) -> tcArg op (arg1, arg1_ty, 1) `thenM` \ arg1' -> addErrCtxt (exprCtxt in_expr) $ tcSubExp res_ty (mkFunTy arg2_ty op_res_ty) `thenM` \ co_fn -> @@ -251,7 +251,7 @@ tcExpr in_expr@(SectionL arg1 op) res_ty tcExpr in_expr@(SectionR op arg2) res_ty = tcInferRho op `thenM` \ (op', op_ty) -> - unifyFunTys 2 op_ty {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) -> + unifyInfixTy op in_expr op_ty `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) -> tcArg op (arg2, arg2_ty, 2) `thenM` \ arg2' -> addErrCtxt (exprCtxt in_expr) $ tcSubExp res_ty (mkFunTy arg1_ty op_res_ty) `thenM` \ co_fn -> @@ -261,22 +261,19 @@ tcExpr in_expr@(SectionR op arg2) res_ty tcExpr in_expr@(OpApp arg1 op fix arg2) res_ty = tcInferRho op `thenM` \ (op', op_ty) -> - unifyFunTys 2 op_ty {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) -> + unifyInfixTy op in_expr op_ty `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) -> tcArg op (arg1, arg1_ty, 1) `thenM` \ arg1' -> tcArg op (arg2, arg2_ty, 2) `thenM` \ arg2' -> addErrCtxt (exprCtxt in_expr) $ tcSubExp res_ty op_res_ty `thenM` \ co_fn -> - returnM (OpApp arg1' op' fix arg2') + returnM (co_fn <$> OpApp arg1' op' fix arg2') \end{code} \begin{code} -tcExpr (HsLet binds (L loc expr)) res_ty - = tcBindsAndThen - glue - binds -- Bindings to check - (setSrcSpan loc $ tcExpr expr res_ty) - where - glue bind expr = HsLet [bind] (L loc expr) +tcExpr (HsLet binds expr) res_ty + = do { (binds', expr') <- tcLocalBinds binds $ + tcMonoExpr expr res_ty + ; return (HsLet binds' expr') } tcExpr in_expr@(HsCase scrut matches) exp_ty = -- We used to typecheck the case alternatives first. @@ -354,34 +351,25 @@ tcExpr e@(HsArrForm _ _ _) _ %************************************************************************ \begin{code} -tcExpr expr@(RecordCon con@(L loc con_name) _ rbinds) res_ty - = addErrCtxt (recordConCtxt expr) $ - addLocM (tcId (OccurrenceOf con_name)) con `thenM` \ (con_expr, _, con_tau) -> - let - (_, record_ty) = tcSplitFunTys con_tau - (tycon, ty_args) = tcSplitTyConApp record_ty - in - ASSERT( isAlgTyCon tycon ) - zapExpectedTo res_ty record_ty `thenM_` +tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty + = addErrCtxt (recordConCtxt expr) $ + do { (con_expr, _, con_tau) <- setSrcSpan loc $ + tcId (OccurrenceOf con_name) con_name + ; data_con <- tcLookupDataCon con_name - -- Check that the record bindings match the constructor - -- con_name is syntactically constrained to be a data constructor - tcLookupDataCon con_name `thenM` \ data_con -> - let - bad_fields = badFields rbinds data_con - in - if notNull bad_fields then - mappM (addErrTc . badFieldCon data_con) bad_fields `thenM_` - failM -- Fail now, because tcRecordBinds will crash on a bad field - else + ; let (arg_tys, record_ty) = tcSplitFunTys con_tau + flds_w_tys = zipEqual "tcExpr RecordCon" (dataConFieldLabels data_con) arg_tys + + -- Make the result type line up + ; zapExpectedTo res_ty record_ty -- Typecheck the record bindings - tcRecordBinds tycon ty_args rbinds `thenM` \ rbinds' -> + ; rbinds' <- tcRecordBinds data_con flds_w_tys rbinds -- Check for missing fields - checkMissingFields data_con rbinds `thenM_` + ; checkMissingFields data_con rbinds - returnM (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') + ; returnM (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') } -- The main complication with RecordUpd is that we need to explicitly -- handle the *non-updated* fields. Consider: @@ -408,6 +396,13 @@ tcExpr expr@(RecordCon con@(L loc con_name) _ rbinds) res_ty -- its RHS is simply an error, so it doesn't impose any type constraints -- -- All this is done in STEP 4 below. +-- +-- Note about GADTs +-- ~~~~~~~~~~~~~~~~ +-- For record update we require that every constructor involved in the +-- update (i.e. that has all the specified fields) is "vanilla". I +-- don't know how to do the update otherwise. + tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty = addErrCtxt (recordUpdCtxt expr) $ @@ -433,28 +428,24 @@ tcExpr 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) - sel_id : _ = sel_ids - (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if - data_cons = tyConDataCons tycon -- it's not a field label - tycon_tyvars = tyConTyVars tycon -- The data cons use the same type vars + upd_field_lbls = recBindFields rbinds + sel_id : _ = sel_ids + (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if + data_cons = tyConDataCons tycon -- it's not a field label + relevant_cons = filter is_relevant data_cons + is_relevant con = all (`elem` dataConFieldLabels con) upd_field_lbls in - tcInstTyVars tycon_tyvars `thenM` \ (_, result_inst_tys, inst_env) -> -- STEP 2 -- Check that at least one constructor has all the named fields -- i.e. has an empty set of bad fields returned by badFields - checkTc (any (null . badFields rbinds) data_cons) + checkTc (not (null relevant_cons)) (badFieldsUpd rbinds) `thenM_` - -- STEP 3 - -- Typecheck the update bindings. - -- (Do this after checking for bad fields in case there's a field that - -- doesn't match the constructor.) - let - result_record_ty = mkTyConApp tycon result_inst_tys - in - zapExpectedTo res_ty result_record_ty `thenM_` - tcRecordBinds tycon result_inst_tys rbinds `thenM` \ rbinds' -> + -- Check that all relevant data cons are vanilla. Doing record updates on + -- GADTs and/or existentials is more than my tiny brain can cope with today + checkTc (all isVanillaDataCon relevant_cons) + (nonVanillaUpd tycon) `thenM_` -- STEP 4 -- Use the un-updated fields to find a vector of booleans saying @@ -463,29 +454,41 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty -- WARNING: this code assumes that all data_cons in a common tycon -- have FieldLabels abstracted over the same tyvars. let - upd_field_lbls = recBindFields rbinds - con_field_lbls_s = map dataConFieldLabels data_cons - -- A constructor is only relevant to this process if - -- it contains all the fields that are being updated - relevant_field_lbls_s = filter is_relevant con_field_lbls_s - is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls + -- it contains *all* the fields that are being updated + con1 = head relevant_cons -- A representative constructor + con1_tyvars = dataConTyVars con1 + con1_fld_tys = dataConFieldLabels con1 `zip` dataConOrigArgTys con1 + common_tyvars = tyVarsOfTypes [ty | (fld,ty) <- con1_fld_tys + , not (fld `elem` upd_field_lbls) ] - non_upd_field_lbls = concat relevant_field_lbls_s `minusList` upd_field_lbls - common_tyvars = tyVarsOfTypes [ty | (fld,ty,_) <- tyConFields tycon, - fld `elem` non_upd_field_lbls] is_common_tv tv = tv `elemVarSet` common_tyvars mk_inst_ty tv result_inst_ty | is_common_tv tv = returnM result_inst_ty -- Same as result type | otherwise = newTyFlexiVarTy (tyVarKind tv) -- Fresh type, of correct kind in - zipWithM mk_inst_ty tycon_tyvars result_inst_tys `thenM` \ inst_tys -> + tcInstTyVars con1_tyvars `thenM` \ (_, result_inst_tys, inst_env) -> + zipWithM mk_inst_ty con1_tyvars result_inst_tys `thenM` \ inst_tys -> + + -- STEP 3 + -- Typecheck the update bindings. + -- (Do this after checking for bad fields in case there's a field that + -- doesn't match the constructor.) + let + result_record_ty = mkTyConApp tycon result_inst_tys + inst_fld_tys = [(fld, substTy inst_env ty) | (fld, ty) <- con1_fld_tys] + in + zapExpectedTo res_ty result_record_ty `thenM_` + tcRecordBinds con1 inst_fld_tys rbinds `thenM` \ rbinds' -> -- STEP 5 -- Typecheck the expression to be updated let - record_ty = mkTyConApp tycon inst_tys + record_ty = ASSERT( length inst_tys == tyConArity tycon ) + mkTyConApp tycon inst_tys + -- This is one place where the isVanilla check is important + -- So that inst_tys matches the tycon in tcCheckRho record_expr record_ty `thenM` \ record_expr' -> @@ -495,7 +498,8 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty -- do pattern matching over the data cons. -- -- What dictionaries do we need? - -- We just take the context of the type constructor + -- We just take the context of the first data constructor + -- This isn't right, but I just can't bear to union up all the relevant ones let theta' = substTheta inst_env (tyConStupidTheta tycon) in @@ -628,14 +632,16 @@ tcApp (L _ (HsApp e1 e2)) args res_ty = tcApp e1 (e2:args) res_ty -- Accumulate the arguments tcApp fun args res_ty - = do { (fun', fun_tvs, fun_tau) <- tcFun fun -- Type-check the function + = do { let n_args = length args + ; (fun', fun_tvs, fun_tau) <- tcFun fun -- Type-check the function -- Extract its argument types ; (expected_arg_tys, actual_res_ty) - <- addErrCtxt (wrongArgsCtxt "too many" fun args) $ do - { traceTc (text "tcApp" <+> (ppr fun $$ ppr fun_tau)) - ; unifyFunTys (length args) fun_tau } - + <- do { traceTc (text "tcApp" <+> (ppr fun $$ ppr fun_tau)) + ; let msg = sep [ptext SLIT("The function") <+> quotes (ppr fun), + ptext SLIT("is applied to") + <+> speakN n_args <+> ptext SLIT("arguments")] + ; unifyFunTys msg n_args fun_tau } ; case res_ty of Check _ -> do -- Connect to result type first @@ -738,6 +744,20 @@ checkArgsCtxt fun args (Check expected_res_ty) actual_res_ty tidy_env | otherwise = appCtxt fun args in returnM (env2, message) + +---------------- +unifyInfixTy :: LHsExpr Name -> HsExpr Name -> TcType + -> TcM ([TcType], TcType) +-- This wrapper just prepares the error message for unifyFunTys +unifyInfixTy op expr op_ty + = unifyFunTys msg 2 op_ty + where + msg = sep [herald <+> quotes (ppr expr), + ptext SLIT("requires") <+> quotes (ppr op) + <+> ptext SLIT("to take two arguments")] + herald = case expr of + OpApp _ _ _ _ -> ptext SLIT("The infix expression") + other -> ptext SLIT("The operator section") \end{code} @@ -783,6 +803,8 @@ tcId orig id_name -- Look up the Id and instantiate its type -- Remember to chuck in the constraints from the "silly context" ; return (expr, tvs, tau) } + ; AGlobal (AnId id) | isNaughtyRecordSelector id + -> failWithTc (naughtyRecordSel id) ; AGlobal (AnId id) -> instantiate id -- A global cannot possibly be ill-staged -- nor does it need the 'lifting' treatment @@ -910,39 +932,25 @@ This extends OK when the field types are universally quantified. \begin{code} tcRecordBinds - :: TyCon -- Type constructor for the record - -> [TcType] -- Args of this type constructor + :: DataCon + -> [(FieldLabel,TcType)] -- Expected type for each field -> HsRecordBinds Name -> TcM (HsRecordBinds TcId) -tcRecordBinds tycon ty_args rbinds - = mappM do_bind rbinds +tcRecordBinds data_con flds_w_tys rbinds + = do { mb_binds <- mappM do_bind rbinds + ; return (catMaybes mb_binds) } where - tenv = zipTopTvSubst (tyConTyVars tycon) ty_args - do_bind (L loc field_lbl, rhs) + | Just field_ty <- assocMaybe flds_w_tys field_lbl = addErrCtxt (fieldCtxt field_lbl) $ - let - field_ty = tyConFieldType tycon field_lbl - field_ty' = substTy tenv field_ty - in - tcCheckSigma rhs field_ty' `thenM` \ rhs' -> - tcLookupId field_lbl `thenM` \ sel_id -> - ASSERT( isRecordSelector sel_id ) - returnM (L loc sel_id, rhs') - -tyConFieldType :: TyCon -> FieldLabel -> Type -tyConFieldType tycon field_lbl - = case [ty | (f,ty,_) <- tyConFields tycon, f == field_lbl] of - (ty:other) -> ASSERT( null other) ty - -- This lookup and assertion will surely succeed, because - -- we check that the fields are indeed record selectors - -- before calling tcRecordBinds - -badFields rbinds data_con - = filter (not . (`elem` field_names)) (recBindFields rbinds) - where - field_names = dataConFieldLabels data_con + do { rhs' <- tcCheckSigma rhs field_ty + ; sel_id <- tcLookupId field_lbl + ; ASSERT( isRecordSelector sel_id ) + return (Just (L loc sel_id, rhs')) } + | otherwise + = do { addErrTc (badFieldCon data_con field_lbl) + ; return Nothing } checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM () checkMissingFields data_con rbinds @@ -998,6 +1006,7 @@ tcCheckRhos (expr:exprs) (ty:tys) = tcCheckRho expr ty `thenM` \ expr' -> tcCheckRhos exprs tys `thenM` \ exprs' -> returnM (expr':exprs') +tcCheckRhos exprs tys = pprPanic "tcCheckRhos" (ppr exprs $$ ppr tys) \end{code} @@ -1062,6 +1071,10 @@ appCtxt fun args where the_app = foldl mkHsApp fun args -- Used in error messages +nonVanillaUpd tycon + = vcat [ptext SLIT("Record update for the non-Haskell-98 data type") <+> quotes (ppr tycon) + <+> ptext SLIT("is not (yet) supported"), + ptext SLIT("Use pattern-matching instead")] badFieldsUpd rbinds = hang (ptext SLIT("No constructor has all these fields:")) 4 (pprQuotedList (recBindFields rbinds)) @@ -1069,6 +1082,11 @@ badFieldsUpd rbinds recordUpdCtxt expr = ptext SLIT("In the record update:") <+> ppr expr recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr +naughtyRecordSel sel_id + = ptext SLIT("Cannot use record selector") <+> quotes (ppr sel_id) <+> + ptext SLIT("as a function due to escaped type variables") $$ + ptext SLIT("Probably fix: use pattern-matching syntax instead") + notSelector field = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]