X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=5520743d753b7cad9f39e109dde6be52c32e9afd;hb=36436bc62a98f53e126ec02fe946337c4c766c3f;hp=03d346f1e4cb02ab1be6a7299e6bb442f7c3c63a;hpb=d18f6b1ec58f8b9e3f67768da8d4daf31d7e79f8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 03d346f..5520743 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -4,13 +4,17 @@ \section[TcExpr]{Typecheck an expression} \begin{code} -module TcExpr ( tcCheckSigma, tcCheckRho, tcInferRho, tcMonoExpr ) where +module TcExpr ( tcCheckSigma, tcCheckRho, tcInferRho, + tcMonoExpr, tcExpr, tcSyntaxOp + ) where #include "HsVersions.h" #ifdef GHCI /* Only if bootstrapped */ import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) +import HsSyn ( nlHsVar ) import Id ( Id ) +import Name ( isExternalName ) import TcType ( isTauTy ) import TcEnv ( checkWellStaged ) import HsSyn ( nlHsApp ) @@ -18,55 +22,53 @@ import qualified DsMeta #endif import HsSyn ( HsExpr(..), LHsExpr, HsLit(..), ArithSeqInfo(..), recBindFields, - HsMatchContext(..), HsRecordBinds, mkHsApp, nlHsVar ) + HsMatchContext(..), HsRecordBinds, mkHsApp ) import TcHsSyn ( hsLitType, (<$>) ) import TcRnMonad -import TcUnify ( Expected(..), tcInfer, zapExpectedType, zapExpectedTo, tcSubExp, tcGen, +import TcUnify ( Expected(..), tcInfer, zapExpectedType, zapExpectedTo, + tcSubExp, tcGen, tcSub, unifyFunTys, zapToListTy, zapToTyConApp ) import BasicTypes ( isMarkedStrict ) -import Inst ( InstOrigin(..), - newOverloadedLit, newMethodFromName, newIPDict, +import Inst ( tcOverloadedLit, newMethodFromName, newIPDict, newDicts, newMethodWithGivenTy, tcInstStupidTheta, tcInstCall ) -import TcBinds ( tcBindsAndThen ) -import TcEnv ( tcLookup, tcLookupId, checkProcLevel, +import TcBinds ( tcLocalBinds ) +import TcEnv ( tcLookup, tcLookupId, tcLookupDataCon, tcLookupGlobalId ) import TcArrows ( tcProc ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMatchCtxt(..) ) import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) -import TcPat ( badFieldCon ) -import TcMType ( tcInstTyVars, tcInstType, newTyFlexiVarTy, zonkTcType, readMetaTyVar ) -import TcType ( Type, TcTyVar, TcType, TcSigmaType, TcRhoType, MetaDetails(..), - tcSplitFunTys, tcSplitTyConApp, mkTyVarTys, +import TcPat ( badFieldCon, refineTyVars ) +import TcMType ( tcInstTyVars, tcInstType, newTyFlexiVarTy, zonkTcType ) +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 DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConWrapId ) +import Id ( idType, recordSelectorFieldLabel, isRecordSelector, isNaughtyRecordSelector ) +import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, + dataConWrapId, isVanillaDataCon, dataConTyVars, dataConOrigArgTys ) import Name ( Name ) -import TyCon ( TyCon, FieldLabel, tyConTyVars, tyConStupidTheta, - tyConDataCons, tyConFields ) -import Type ( zipTopTvSubst, mkTopTvSubst, substTheta, substTy ) +import TyCon ( TyCon, FieldLabel, tyConStupidTheta, tyConArity, tyConDataCons ) +import Type ( substTheta, substTy ) +import Var ( tyVarKind ) import VarSet ( emptyVarSet, elemVarSet ) import TysWiredIn ( boolTy, parrTyCon, tupleTyCon ) import PrelNames ( enumFromName, enumFromThenName, enumFromToName, enumFromThenToName, - enumFromToPName, enumFromThenToPName + enumFromToPName, enumFromThenToPName, negateName ) -import ListSetOps ( minusList ) -import CmdLineOpts +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 ) -#endif \end{code} %************************************************************************ @@ -82,7 +84,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 @@ -107,8 +109,17 @@ tcCheckRho expr rho_ty = tcMonoExpr expr (Check rho_ty) tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) tcInferRho (L loc (HsVar name)) = setSrcSpan loc $ do - { (e,_,ty) <- tcId name; return (L loc e, ty)} + { (e,_,ty) <- tcId (OccurrenceOf name) name + ; return (L loc e, ty) } tcInferRho expr = tcInfer (tcMonoExpr expr) + +tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId) +-- Typecheck a syntax operator, checking that it has the specified type +-- The operator is always a variable at this stage (i.e. renamer output) +tcSyntaxOp orig (HsVar op) ty = do { (expr', _, id_ty) <- tcId orig op + ; co_fn <- tcSub ty id_ty + ; returnM (co_fn <$> expr') } +tcSyntaxOp orig other ty = pprPanic "tcSyntaxOp" (ppr other) \end{code} @@ -127,16 +138,16 @@ tcMonoExpr :: LHsExpr Name -- Expession to type check -> TcM (LHsExpr TcId) tcMonoExpr (L loc expr) res_ty - = setSrcSpan loc (do { expr' <- tc_expr expr res_ty + = setSrcSpan loc (do { expr' <- tcExpr expr res_ty ; return (L loc expr') }) -tc_expr :: HsExpr Name -> Expected TcRhoType -> TcM (HsExpr TcId) -tc_expr (HsVar name) res_ty - = do { (expr', _, id_ty) <- tcId name +tcExpr :: HsExpr Name -> Expected TcRhoType -> TcM (HsExpr TcId) +tcExpr (HsVar name) res_ty + = do { (expr', _, id_ty) <- tcId (OccurrenceOf name) name ; co_fn <- tcSubExp res_ty id_ty ; returnM (co_fn <$> expr') } -tc_expr (HsIPVar ip) res_ty +tcExpr (HsIPVar ip) res_ty = -- Implicit parameters must have a *tau-type* not a -- type scheme. We enforce this by creating a fresh -- type variable as its type. (Because res_ty may not @@ -157,13 +168,13 @@ tc_expr (HsIPVar ip) res_ty %************************************************************************ \begin{code} -tc_expr in_expr@(ExprWithTySig expr poly_ty) res_ty +tcExpr in_expr@(ExprWithTySig expr poly_ty) res_ty = addErrCtxt (exprCtxt in_expr) $ tcHsSigType ExprSigCtxt poly_ty `thenM` \ sig_tc_ty -> tcThingWithSig sig_tc_ty (tcCheckRho expr) res_ty `thenM` \ (co_fn, expr') -> returnM (co_fn <$> ExprWithTySigOut expr' poly_ty) -tc_expr (HsType ty) res_ty +tcExpr (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) @@ -180,29 +191,35 @@ tc_expr (HsType ty) res_ty %************************************************************************ \begin{code} -tc_expr (HsPar expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> +tcExpr (HsPar expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> returnM (HsPar expr') -tc_expr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> +tcExpr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> returnM (HsSCC lbl expr') -tc_expr (HsCoreAnn lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> -- hdaume: core annotation +tcExpr (HsCoreAnn lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> -- hdaume: core annotation returnM (HsCoreAnn lbl expr') -tc_expr (HsLit lit) res_ty = tcLit lit res_ty +tcExpr (HsLit lit) res_ty = tcLit lit res_ty -tc_expr (HsOverLit lit) res_ty +tcExpr (HsOverLit lit) res_ty = zapExpectedType res_ty liftedTypeKind `thenM` \ res_ty' -> - newOverloadedLit (LiteralOrigin lit) lit res_ty' `thenM` \ lit_expr -> - returnM (unLoc lit_expr) -- ToDo: nasty unLoc - -tc_expr (NegApp expr neg_name) res_ty - = tc_expr (HsApp (nlHsVar neg_name) expr) res_ty - -- ToDo: use tcSyntaxName - -tc_expr (HsLam match) res_ty + -- Overloaded literals must have liftedTypeKind, because + -- we're instantiating an overloaded function here, + -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2 + tcOverloadedLit (LiteralOrigin lit) lit res_ty' `thenM` \ lit' -> + returnM (HsOverLit lit') + +tcExpr (NegApp expr neg_expr) res_ty + = do { res_ty' <- zapExpectedType res_ty liftedTypeKind + ; neg_expr' <- tcSyntaxOp (OccurrenceOf negateName) neg_expr + (mkFunTy res_ty' res_ty') + ; expr' <- tcCheckRho expr res_ty' + ; return (NegApp expr' neg_expr') } + +tcExpr (HsLam match) res_ty = tcMatchLambda match res_ty `thenM` \ match' -> returnM (HsLam match') -tc_expr (HsApp e1 e2) res_ty +tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty \end{code} @@ -217,9 +234,9 @@ a type error will occur if they aren't. -- or just -- op e -tc_expr in_expr@(SectionL arg1 op) res_ty +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 -> @@ -228,9 +245,9 @@ tc_expr in_expr@(SectionL arg1 op) res_ty -- Right sections, equivalent to \ x -> x op expr, or -- \ x -> op x expr -tc_expr in_expr@(SectionR op arg2) 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 -> @@ -238,26 +255,23 @@ tc_expr in_expr@(SectionR op arg2) res_ty -- equivalent to (op e1) e2: -tc_expr in_expr@(OpApp arg1 op fix 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} -tc_expr (HsLet binds (L loc expr)) res_ty - = tcBindsAndThen - glue - binds -- Bindings to check - (setSrcSpan loc $ tc_expr 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') } -tc_expr in_expr@(HsCase scrut matches) exp_ty +tcExpr in_expr@(HsCase scrut matches) exp_ty = -- We used to typecheck the case alternatives first. -- The case patterns tend to give good type info to use -- when typechecking the scrutinee. For example @@ -277,9 +291,9 @@ tc_expr in_expr@(HsCase scrut matches) exp_ty match_ctxt = MC { mc_what = CaseAlt, mc_body = tcMonoExpr } -tc_expr (HsIf pred b1 b2) res_ty - = addErrCtxt (predCtxt pred) ( - tcCheckRho pred boolTy ) `thenM` \ pred' -> +tcExpr (HsIf pred b1 b2) res_ty + = addErrCtxt (predCtxt pred) + (tcCheckRho pred boolTy) `thenM` \ pred' -> zapExpectedType res_ty openTypeKind `thenM` \ res_ty' -> -- C.f. the call to zapToType in TcMatches.tcMatches @@ -288,13 +302,10 @@ tc_expr (HsIf pred b1 b2) res_ty tcCheckRho b2 res_ty' `thenM` \ b2' -> returnM (HsIf pred' b1' b2') -tc_expr (HsDo do_or_lc stmts method_names _) res_ty - = zapExpectedType res_ty liftedTypeKind `thenM` \ res_ty' -> - -- All comprehensions yield a monotype of kind * - tcDoStmts do_or_lc stmts method_names res_ty' `thenM` \ (stmts', methods') -> - returnM (HsDo do_or_lc stmts' methods' res_ty') +tcExpr (HsDo do_or_lc stmts body _) res_ty + = tcDoStmts do_or_lc stmts body res_ty -tc_expr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list +tcExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list = zapToListTy res_ty `thenM` \ elt_ty -> mappM (tc_elt elt_ty) exprs `thenM` \ exprs' -> returnM (ExplicitList elt_ty exprs') @@ -303,7 +314,7 @@ tc_expr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list = addErrCtxt (listCtxt expr) $ tcCheckRho expr elt_ty -tc_expr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty +tcExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty = do { [elt_ty] <- zapToTyConApp parrTyCon res_ty ; exprs' <- mappM (tc_elt elt_ty) exprs ; return (ExplicitPArr elt_ty exprs') } @@ -311,20 +322,20 @@ tc_expr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty tc_elt elt_ty expr = addErrCtxt (parrCtxt expr) (tcCheckRho expr elt_ty) -tc_expr (ExplicitTuple exprs boxity) res_ty +tcExpr (ExplicitTuple exprs boxity) res_ty = do { arg_tys <- zapToTyConApp (tupleTyCon boxity (length exprs)) res_ty ; exprs' <- tcCheckRhos exprs arg_tys ; return (ExplicitTuple exprs' boxity) } -tc_expr (HsProc pat cmd) res_ty +tcExpr (HsProc pat cmd) res_ty = tcProc pat cmd res_ty `thenM` \ (pat', cmd') -> returnM (HsProc pat' cmd') -tc_expr e@(HsArrApp _ _ _ _ _) _ +tcExpr e@(HsArrApp _ _ _ _ _) _ = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e), ptext SLIT("was found where an expression was expected")]) -tc_expr e@(HsArrForm _ _ _) _ +tcExpr e@(HsArrForm _ _ _) _ = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e), ptext SLIT("was found where an expression was expected")]) \end{code} @@ -336,34 +347,25 @@ tc_expr e@(HsArrForm _ _ _) _ %************************************************************************ \begin{code} -tc_expr expr@(RecordCon con@(L loc con_name) rbinds) res_ty - = addErrCtxt (recordConCtxt expr) $ - addLocM tcId 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 (RecordConOut data_con (L loc 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: @@ -391,7 +393,7 @@ tc_expr expr@(RecordCon con@(L loc con_name) rbinds) res_ty -- -- All this is done in STEP 4 below. -tc_expr expr@(RecordUpd record_expr rbinds) res_ty +tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty = addErrCtxt (recordUpdCtxt expr) $ -- STEP 0 @@ -418,9 +420,14 @@ tc_expr expr@(RecordUpd record_expr rbinds) res_ty 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 in - tcInstTyVars tycon_tyvars `thenM` \ (_, result_inst_tys, inst_env) -> + + -- Check that all data cons are vanilla. Doing record updates on GADTs + -- and/or existentials is more than my tiny brain can cope with today + -- [I think we might be able to manage if none of the selectors is naughty, + -- but that's for another day.] + checkTc (all isVanillaDataCon data_cons) + (nonVanillaUpd tycon) `thenM_` -- STEP 2 -- Check that at least one constructor has all the named fields @@ -428,16 +435,6 @@ tc_expr expr@(RecordUpd record_expr rbinds) res_ty checkTc (any (null . badFields rbinds) data_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' -> - -- STEP 4 -- Use the un-updated fields to find a vector of booleans saying -- which type arguments must be the same in updatee and result. @@ -446,28 +443,44 @@ tc_expr expr@(RecordUpd record_expr rbinds) res_ty -- 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 - - 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] - - mk_inst_ty tyvar result_inst_ty - | tyvar `elemVarSet` common_tyvars = returnM result_inst_ty -- Same as result type --- gaw 2004 FIX? - | otherwise = newTyFlexiVarTy liftedTypeKind -- Fresh type + -- it contains *all* the fields that are being updated + relevant_cons = filter is_relevant data_cons + is_relevant con = all (`elem` dataConFieldLabels con) upd_field_lbls + 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) ] + + 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' -> @@ -477,7 +490,8 @@ tc_expr 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 @@ -485,7 +499,7 @@ tc_expr expr@(RecordUpd record_expr rbinds) res_ty extendLIEs dicts `thenM_` -- Phew! - returnM (RecordUpdOut record_expr' record_ty result_record_ty rbinds') + returnM (RecordUpd record_expr' rbinds' record_ty result_record_ty) \end{code} @@ -498,16 +512,16 @@ tc_expr expr@(RecordUpd record_expr rbinds) res_ty %************************************************************************ \begin{code} -tc_expr (ArithSeqIn seq@(From expr)) res_ty +tcExpr (ArithSeq _ seq@(From expr)) res_ty = zapToListTy res_ty `thenM` \ elt_ty -> tcCheckRho expr elt_ty `thenM` \ expr' -> newMethodFromName (ArithSeqOrigin seq) elt_ty enumFromName `thenM` \ enum_from -> - returnM (ArithSeqOut (nlHsVar enum_from) (From expr')) + returnM (ArithSeq (HsVar enum_from) (From expr')) -tc_expr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty +tcExpr in_expr@(ArithSeq _ seq@(FromThen expr1 expr2)) res_ty = addErrCtxt (arithSeqCtxt in_expr) $ zapToListTy res_ty `thenM` \ elt_ty -> tcCheckRho expr1 elt_ty `thenM` \ expr1' -> @@ -515,10 +529,10 @@ tc_expr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty newMethodFromName (ArithSeqOrigin seq) elt_ty enumFromThenName `thenM` \ enum_from_then -> - returnM (ArithSeqOut (nlHsVar enum_from_then) (FromThen expr1' expr2')) + returnM (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) -tc_expr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty +tcExpr in_expr@(ArithSeq _ seq@(FromTo expr1 expr2)) res_ty = addErrCtxt (arithSeqCtxt in_expr) $ zapToListTy res_ty `thenM` \ elt_ty -> tcCheckRho expr1 elt_ty `thenM` \ expr1' -> @@ -526,9 +540,9 @@ tc_expr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty newMethodFromName (ArithSeqOrigin seq) elt_ty enumFromToName `thenM` \ enum_from_to -> - returnM (ArithSeqOut (nlHsVar enum_from_to) (FromTo expr1' expr2')) + returnM (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) -tc_expr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty +tcExpr in_expr@(ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty = addErrCtxt (arithSeqCtxt in_expr) $ zapToListTy res_ty `thenM` \ elt_ty -> tcCheckRho expr1 elt_ty `thenM` \ expr1' -> @@ -537,9 +551,9 @@ tc_expr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty newMethodFromName (ArithSeqOrigin seq) elt_ty enumFromThenToName `thenM` \ eft -> - returnM (ArithSeqOut (nlHsVar eft) (FromThenTo expr1' expr2' expr3')) + returnM (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) -tc_expr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty +tcExpr in_expr@(PArrSeq _ seq@(FromTo expr1 expr2)) res_ty = addErrCtxt (parrSeqCtxt in_expr) $ zapToTyConApp parrTyCon res_ty `thenM` \ [elt_ty] -> tcCheckRho expr1 elt_ty `thenM` \ expr1' -> @@ -547,9 +561,9 @@ tc_expr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty newMethodFromName (PArrSeqOrigin seq) elt_ty enumFromToPName `thenM` \ enum_from_to -> - returnM (PArrSeqOut (nlHsVar enum_from_to) (FromTo expr1' expr2')) + returnM (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) -tc_expr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty +tcExpr in_expr@(PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty = addErrCtxt (parrSeqCtxt in_expr) $ zapToTyConApp parrTyCon res_ty `thenM` \ [elt_ty] -> tcCheckRho expr1 elt_ty `thenM` \ expr1' -> @@ -558,9 +572,9 @@ tc_expr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty newMethodFromName (PArrSeqOrigin seq) elt_ty enumFromThenToPName `thenM` \ eft -> - returnM (PArrSeqOut (nlHsVar eft) (FromThenTo expr1' expr2' expr3')) + returnM (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) -tc_expr (PArrSeqIn _) _ +tcExpr (PArrSeq _ _) _ = panic "TcExpr.tcMonoExpr: Infinite parallel array!" -- the parser shouldn't have generated it and the renamer shouldn't have -- let it through @@ -576,8 +590,8 @@ tc_expr (PArrSeqIn _) _ \begin{code} #ifdef GHCI /* Only if bootstrapped */ -- Rename excludes these cases otherwise -tc_expr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty -tc_expr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty +tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty +tcExpr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty ; return (unLoc e) } #endif /* GHCI */ \end{code} @@ -590,7 +604,7 @@ tc_expr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty %************************************************************************ \begin{code} -tc_expr other _ = pprPanic "tcMonoExpr" (ppr other) +tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) \end{code} @@ -610,14 +624,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 @@ -631,7 +647,8 @@ tcApp fun args res_ty Infer _ -> do -- Type check args first, then -- refine result type, then do tcResult { the_app' <- tcArgs fun fun' args expected_arg_tys - ; actual_res_ty' <- refineResultTy fun_tvs actual_res_ty + ; subst <- refineTyVars fun_tvs + ; let actual_res_ty' = substTy subst actual_res_ty ; co_fn <- tcResult fun args res_ty actual_res_ty' ; traceTc (text "tcApp: infer" <+> vcat [ppr fun <+> ppr args, ppr the_app', ppr actual_res_ty, ppr actual_res_ty']) @@ -667,7 +684,7 @@ tcFun :: LHsExpr Name -> TcM (LHsExpr TcId, [TcTyVar], TcRhoType) -- If the function isn't simple, infer its type, and return no -- type variables tcFun (L loc (HsVar f)) = setSrcSpan loc $ do - { (fun', tvs, fun_tau) <- tcId f + { (fun', tvs, fun_tau) <- tcId (OccurrenceOf f) f ; return (L loc fun', tvs, fun_tau) } tcFun fun = do { (fun', fun_tau) <- tcInfer (tcMonoExpr fun) ; return (fun', [], fun_tau) } @@ -721,22 +738,18 @@ checkArgsCtxt fun args (Check expected_res_ty) actual_res_ty tidy_env returnM (env2, message) ---------------- -refineResultTy :: [TcTyVar] -- Newly instantiated meta-tyvars of the function - -> TcType -- Result type, instantiated with those tyvars - -> TcM TcType -- Refined result type --- De-wobblify the result type, by taking account what we learned --- from type-checking the arguments. Just one level of de-wobblification --- though. What a hack! -refineResultTy tvs res_ty - = do { mb_prs <- mapM mk_pr tvs - ; let subst = mkTopTvSubst (catMaybes mb_prs) - ; return (substTy subst res_ty) } +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 - mk_pr tv = do { details <- readMetaTyVar tv - ; case details of - Indirect ty -> return (Just (tv,ty)) - other -> return Nothing - } + 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} @@ -769,28 +782,28 @@ This gets a bit less sharing, but b) perhaps fewer separated lambdas \begin{code} -tcId :: Name -> TcM (HsExpr TcId, [TcTyVar], TcRhoType) +tcId :: InstOrigin -> Name -> TcM (HsExpr TcId, [TcTyVar], TcRhoType) -- Return the type variables at which the function -- is instantiated, as well as the translated variable and its type -tcId name -- Look up the Id and instantiate its type - = tcLookup name `thenM` \ thing -> +tcId orig id_name -- Look up the Id and instantiate its type + = tcLookup id_name `thenM` \ thing -> case thing of { - AGlobal (AnId id) -> instantiate id - -- A global cannot possibly be ill-staged - -- nor does it need the 'lifting' treatment - - ; AGlobal (ADataCon con) -- Similar, but instantiate the stupid theta too + AGlobal (ADataCon con) -- Similar, but instantiate the stupid theta too -> do { (expr, tvs, tau) <- instantiate (dataConWrapId con) ; tcInstStupidTheta con (mkTyVarTys tvs) -- Remember to chuck in the constraints from the "silly context" ; return (expr, tvs, tau) } - ; ATcId id th_level proc_level - -> do { checkProcLevel id proc_level - ; tc_local_id id th_level } + ; 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 + + ; ATcId id th_level -> tc_local_id id th_level - ; other -> pprPanic "tcId" (ppr name $$ ppr thing) + ; other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected")) } where @@ -805,33 +818,48 @@ tcId name -- Look up the Id and instantiate its type case use_stage of Brack use_lvl ps_var lie_var | use_lvl > th_bind_lvl - -> -- E.g. \x -> [| h x |] - -- We must behave as if the reference to x was - -- h $(lift x) - -- We use 'x' itself as the splice proxy, used by - -- the desugarer to stitch it all back together. - -- If 'x' occurs many times we may get many identical - -- bindings of the same splice proxy, but that doesn't - -- matter, although it's a mite untidy. - let - id_ty = idType id - in - checkTc (isTauTy id_ty) (polySpliceErr id) `thenM_` - -- If x is polymorphic, its occurrence sites might - -- have different instantiations, so we can't use plain - -- 'x' as the splice proxy name. I don't know how to - -- solve this, and it's probably unimportant, so I'm - -- just going to flag an error for now - - setLIEVar lie_var ( - newMethodFromName orig id_ty DsMeta.liftName `thenM` \ lift -> - -- Put the 'lift' constraint into the right LIE - - -- Update the pending splices - readMutVar ps_var `thenM` \ ps -> - writeMutVar ps_var ((name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps) `thenM_` - - returnM (HsVar id, [], id_ty)) + -> if isExternalName id_name then + -- Top-level identifiers in this module, + -- (which have External Names) + -- are just like the imported case: + -- no need for the 'lifting' treatment + -- E.g. this is fine: + -- f x = x + -- g y = [| f 3 |] + -- But we do need to put f into the keep-alive + -- set, because after desugaring the code will + -- only mention f's *name*, not f itself. + keepAliveTc id_name `thenM_` + instantiate id + + else -- Nested identifiers, such as 'x' in + -- E.g. \x -> [| h x |] + -- We must behave as if the reference to x was + -- h $(lift x) + -- We use 'x' itself as the splice proxy, used by + -- the desugarer to stitch it all back together. + -- If 'x' occurs many times we may get many identical + -- bindings of the same splice proxy, but that doesn't + -- matter, although it's a mite untidy. + let + id_ty = idType id + in + checkTc (isTauTy id_ty) (polySpliceErr id) `thenM_` + -- If x is polymorphic, its occurrence sites might + -- have different instantiations, so we can't use plain + -- 'x' as the splice proxy name. I don't know how to + -- solve this, and it's probably unimportant, so I'm + -- just going to flag an error for now + + setLIEVar lie_var ( + newMethodFromName orig id_ty DsMeta.liftName `thenM` \ lift -> + -- Put the 'lift' constraint into the right LIE + + -- Update the pending splices + readMutVar ps_var `thenM` \ ps -> + writeMutVar ps_var ((id_name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps) `thenM_` + + returnM (HsVar id, [], id_ty)) other -> checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage `thenM_` @@ -869,8 +897,6 @@ tcId name -- Look up the Id and instantiate its type | otherwise = case tcSplitSigmaTy fun_ty of (_,[],_) -> False -- Not overloaded (_,theta,_) -> not (any isLinearPred theta) - - orig = OccurrenceOf name \end{code} %************************************************************************ @@ -898,34 +924,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 + 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 } badFields rbinds data_con = filter (not . (`elem` field_names)) (recBindFields rbinds) @@ -986,6 +1003,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} @@ -1050,6 +1068,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)) @@ -1057,6 +1079,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")]