X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=5520743d753b7cad9f39e109dde6be52c32e9afd;hb=7bb59f381da3728f53ae5ea1bf821154f53c3f94;hp=60226de6e76727eca3e4aa7f8319728c1df6f9f6;hpb=550421384b8364cdaf3135f7859c9f7d7ee1fff1;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 60226de..5520743 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -4,70 +4,71 @@ \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 ) import qualified DsMeta #endif import HsSyn ( HsExpr(..), LHsExpr, HsLit(..), ArithSeqInfo(..), recBindFields, - HsMatchContext(..), HsRecordBinds, mkHsApp, nlHsVar, - nlHsApp ) -import TcHsSyn ( hsLitType, mkHsDictApp, mkHsTyApp, (<$>) ) + HsMatchContext(..), HsRecordBinds, mkHsApp ) +import TcHsSyn ( hsLitType, (<$>) ) import TcRnMonad -import TcUnify ( Expected(..), newHole, zapExpectedType, zapExpectedTo, tcSubExp, tcGen, - unifyFunTy, zapToListTy, zapToPArrTy, zapToTupleTy ) +import TcUnify ( Expected(..), tcInfer, zapExpectedType, zapExpectedTo, + tcSubExp, tcGen, tcSub, + unifyFunTys, zapToListTy, zapToTyConApp ) import BasicTypes ( isMarkedStrict ) -import Inst ( InstOrigin(..), - newOverloadedLit, newMethodFromName, newIPDict, - newDicts, newMethodWithGivenTy, - instToId, tcInstCall, tcInstDataCon - ) -import TcBinds ( tcBindsAndThen ) -import TcEnv ( tcLookup, tcLookupId, checkProcLevel, +import Inst ( tcOverloadedLit, newMethodFromName, newIPDict, + newDicts, newMethodWithGivenTy, tcInstStupidTheta, tcInstCall ) +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, newTyVarTy, zonkTcType ) -import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv), - tcSplitFunTys, tcSplitTyConApp, mkTyVarTys, - isSigmaTy, mkFunTy, mkFunTys, - mkTyConApp, tyVarsOfTypes, isLinearPred, - liftedTypeKind, openTypeKind, +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 FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon ) -import Id ( idType, recordSelectorFieldLabel, isRecordSelector ) -import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConWrapId ) +import Kind ( openTypeKind, liftedTypeKind, argTypeKind ) + +import Id ( idType, recordSelectorFieldLabel, isRecordSelector, isNaughtyRecordSelector ) +import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, + dataConWrapId, isVanillaDataCon, dataConTyVars, dataConOrigArgTys ) import Name ( Name ) -import TyCon ( TyCon, tyConTyVars, tyConTheta, tyConDataCons ) -import Subst ( mkTopTyVarSubst, substTheta, substTy ) +import TyCon ( TyCon, FieldLabel, tyConStupidTheta, tyConArity, tyConDataCons ) +import Type ( substTheta, substTy ) +import Var ( tyVarKind ) import VarSet ( emptyVarSet, elemVarSet ) -import TysWiredIn ( boolTy ) +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} %************************************************************************ @@ -83,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,12 +108,18 @@ tcCheckRho :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId) tcCheckRho expr rho_ty = tcMonoExpr expr (Check rho_ty) tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) -tcInferRho (L loc (HsVar name)) = addSrcSpan loc $ - do { (e,ty) <- tcId name; return (L loc e, ty)} -tcInferRho expr = newHole `thenM` \ hole -> - tcMonoExpr expr (Infer hole) `thenM` \ expr' -> - readMutVar hole `thenM` \ rho_ty -> - returnM (expr', rho_ty) +tcInferRho (L loc (HsVar name)) = setSrcSpan loc $ do + { (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} @@ -131,21 +138,22 @@ tcMonoExpr :: LHsExpr Name -- Expession to type check -> TcM (LHsExpr TcId) tcMonoExpr (L loc expr) res_ty - = addSrcSpan 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 - = tcId name `thenM` \ (expr', id_ty) -> - tcSubExp res_ty id_ty `thenM` \ co_fn -> - returnM (co_fn <$> expr') +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 -- be a tau-type.) - newTyVarTy openTypeKind `thenM` \ ip_ty -> + newTyFlexiVarTy argTypeKind `thenM` \ ip_ty -> + -- argTypeKind: it can't be an unboxed tuple newIPDict (IPOccOrigin ip) ip ip_ty `thenM` \ (ip', inst) -> extendLIE inst `thenM_` tcSubExp res_ty ip_ty `thenM` \ co_fn -> @@ -160,14 +168,13 @@ tc_expr (HsIPVar ip) res_ty %************************************************************************ \begin{code} -tc_expr in_expr@(ExprWithTySig expr poly_ty) res_ty - = addErrCtxt (exprSigCtxt in_expr) $ +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 <$> unLoc expr') - -- ToDo: nasty unLoc + 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) @@ -184,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 - = zapExpectedType res_ty `thenM` \ res_ty' -> - newOverloadedLit (LiteralOrigin lit) lit res_ty' `thenM` \ lit_expr -> - returnM (unLoc lit_expr) -- ToDo: nasty unLoc +tcExpr (HsOverLit lit) res_ty + = zapExpectedType res_ty liftedTypeKind `thenM` \ 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') -tc_expr (NegApp expr neg_name) res_ty - = tc_expr (HsApp (nlHsVar neg_name) expr) res_ty - -- ToDo: use tcSyntaxName +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') } -tc_expr (HsLam match) res_ty +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} @@ -221,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) -> - split_fun_ty op_ty 2 {- 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 -> @@ -232,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) -> - split_fun_ty op_ty 2 {- 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 -> @@ -242,64 +255,57 @@ 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) -> - split_fun_ty op_ty 2 {- 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 - (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) res_ty - = addErrCtxt (caseCtxt in_expr) $ - - -- Typecheck the case alternatives first. +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 -- case (map f) of -- (x:xs) -> ... -- will report that map is applied to too few arguments - - tcMatchesCase match_ctxt matches res_ty `thenM` \ (scrut_ty, matches') -> - - addErrCtxt (caseScrutCtxt scrut) ( - tcCheckRho scrut scrut_ty - ) `thenM` \ scrut' -> - - returnM (HsCase scrut' matches') - where + -- + -- But now, in the GADT world, we need to typecheck the scrutinee + -- first, to get type info that may be refined in the case alternatives + addErrCtxt (caseScrutCtxt scrut) + (tcInferRho scrut) `thenM` \ (scrut', scrut_ty) -> + + addErrCtxt (caseCtxt in_expr) $ + tcMatchesCase match_ctxt scrut_ty matches exp_ty `thenM` \ matches' -> + returnM (HsCase scrut' matches') + where 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 `thenM` \ res_ty' -> + zapExpectedType res_ty openTypeKind `thenM` \ res_ty' -> -- C.f. the call to zapToType in TcMatches.tcMatches tcCheckRho b1 res_ty' `thenM` \ b1' -> 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 `thenM` \ res_ty' -> - -- All comprehensions yield a monotype - 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') @@ -308,23 +314,30 @@ 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 - = zapToPArrTy res_ty `thenM` \ elt_ty -> - mappM (tc_elt elt_ty) exprs `thenM` \ exprs' -> - returnM (ExplicitPArr elt_ty exprs') +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') } where tc_elt elt_ty expr - = addErrCtxt (parrCtxt expr) $ - tcCheckRho expr elt_ty + = addErrCtxt (parrCtxt expr) (tcCheckRho expr elt_ty) -tc_expr (ExplicitTuple exprs boxity) res_ty - = zapToTupleTy boxity (length exprs) res_ty `thenM` \ arg_tys -> - tcCheckRhos exprs arg_tys `thenM` \ exprs' -> - returnM (ExplicitTuple exprs' boxity) +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') + +tcExpr e@(HsArrApp _ _ _ _ _) _ + = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e), + ptext SLIT("was found where an expression was expected")]) + +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} %************************************************************************ @@ -334,35 +347,25 @@ tc_expr (HsProc pat cmd) res_ty %************************************************************************ \begin{code} -tc_expr expr@(RecordCon con@(L _ 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 - getSrcSpanM `thenM` \ loc -> - 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: @@ -390,7 +393,7 @@ tc_expr expr@(RecordCon con@(L _ 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 @@ -403,7 +406,7 @@ tc_expr expr@(RecordUpd record_expr rbinds) res_ty -- The renamer has already checked that they -- are all in scope let - bad_guys = [ addSrcSpan loc $ addErrTc (notSelector field_name) + bad_guys = [ setSrcSpan loc $ addErrTc (notSelector field_name) | (L loc field_name, sel_id) <- field_names `zip` sel_ids, not (isRecordSelector sel_id) -- Excludes class ops ] @@ -415,28 +418,22 @@ tc_expr expr@(RecordUpd record_expr rbinds) res_ty let -- It's OK to use the non-tc splitters here (for a selector) sel_id : _ = sel_ids - field_lbl = recordSelectorFieldLabel sel_id -- We've failed already if - tycon = fieldLabelTyCon field_lbl -- it's not a field label - data_cons = tyConDataCons tycon - tycon_tyvars = tyConTyVars tycon -- The data cons use the same type vars + (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if + data_cons = tyConDataCons tycon -- it's not a field label in - tcInstTyVars VanillaTv 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 -- i.e. has an empty set of bad fields returned by badFields 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' -> + (badFieldsUpd rbinds) `thenM_` -- STEP 4 -- Use the un-updated fields to find a vector of booleans saying @@ -445,27 +442,45 @@ tc_expr 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 = map recordSelectorFieldLabel (recBindFields rbinds') - con_field_lbls_s = map dataConFieldLabels data_cons + upd_field_lbls = recBindFields rbinds -- 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 (map fieldLabelType non_upd_field_lbls) + -- 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 + tcInstTyVars con1_tyvars `thenM` \ (_, result_inst_tys, inst_env) -> + zipWithM mk_inst_ty con1_tyvars result_inst_tys `thenM` \ inst_tys -> - mk_inst_ty (tyvar, result_inst_ty) - | tyvar `elemVarSet` common_tyvars = returnM result_inst_ty -- Same as result type - | otherwise = newTyVarTy liftedTypeKind -- Fresh type + -- 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 - mappM mk_inst_ty (zip tycon_tyvars result_inst_tys) `thenM` \ inst_tys -> + 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' -> @@ -475,15 +490,16 @@ 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 (tyConTheta tycon) + theta' = substTheta inst_env (tyConStupidTheta tycon) in newDicts RecordUpdOrigin theta' `thenM` \ dicts -> 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} @@ -496,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' -> @@ -513,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' -> @@ -524,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' -> @@ -535,30 +551,30 @@ 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) $ - zapToPArrTy res_ty `thenM` \ elt_ty -> + zapToTyConApp parrTyCon res_ty `thenM` \ [elt_ty] -> tcCheckRho expr1 elt_ty `thenM` \ expr1' -> tcCheckRho expr2 elt_ty `thenM` \ expr2' -> 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) $ - zapToPArrTy res_ty `thenM` \ elt_ty -> + zapToTyConApp parrTyCon res_ty `thenM` \ [elt_ty] -> tcCheckRho expr1 elt_ty `thenM` \ expr1' -> tcCheckRho expr2 elt_ty `thenM` \ expr2' -> tcCheckRho expr3 elt_ty `thenM` \ expr3' -> 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 @@ -574,11 +590,9 @@ tc_expr (PArrSeqIn _) _ \begin{code} #ifdef GHCI /* Only if bootstrapped */ -- Rename excludes these cases otherwise - -tc_expr (HsSplice n expr) res_ty = tcSpliceExpr n expr res_ty -tc_expr (HsBracket brack) res_ty = do - e <- tcBracket brack res_ty - return (unLoc e) +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 %************************************************************************ \begin{code} -tc_expr other _ = pprPanic "tcMonoExpr" (ppr other) +tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) \end{code} @@ -604,57 +618,108 @@ tc_expr other _ = pprPanic "tcMonoExpr" (ppr other) tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args -> Expected TcRhoType -- Expected result type of application - -> TcM (HsExpr TcId) -- Translated fun and args + -> TcM (HsExpr TcId) -- Translated fun and args tcApp (L _ (HsApp e1 e2)) args res_ty = tcApp e1 (e2:args) res_ty -- Accumulate the arguments tcApp fun args res_ty - = -- First type-check the function - tcInferRho fun `thenM` \ (fun', fun_ty) -> - - addErrCtxt (wrongArgsCtxt "too many" fun args) ( - traceTc (text "tcApp" <+> (ppr fun $$ ppr fun_ty)) `thenM_` - split_fun_ty fun_ty (length args) - ) `thenM` \ (expected_arg_tys, actual_result_ty) -> - - -- Unify with expected result before (was: after) type-checking the args - -- so that the info from res_ty (was: args) percolates to args (was actual_result_ty). - -- This is when we might detect a too-few args situation. - -- (One can think of cases when the opposite order would give - -- a better error message.) - -- [March 2003: I'm experimenting with putting this first. Here's an - -- example where it actually makes a real difference - -- class C t a b | t a -> b - -- instance C Char a Bool - -- - -- data P t a = forall b. (C t a b) => MkP b - -- data Q t = MkQ (forall a. P t a) - - -- f1, f2 :: Q Char; - -- f1 = MkQ (MkP True) - -- f2 = MkQ (MkP True :: forall a. P Char a) - -- - -- With the change, f1 will type-check, because the 'Char' info from - -- the signature is propagated into MkQ's argument. With the check - -- in the other order, the extra signature in f2 is reqd.] - - addErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) - (tcSubExp res_ty actual_result_ty) `thenM` \ co_fn -> + = 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) + <- 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 + -- See Note [Push result type in] + { co_fn <- tcResult fun args res_ty actual_res_ty + ; the_app' <- tcArgs fun fun' args expected_arg_tys + ; traceTc (text "tcApp: check" <+> vcat [ppr fun <+> ppr args, + ppr the_app', ppr actual_res_ty]) + ; returnM (co_fn <$> the_app') } + + Infer _ -> do -- Type check args first, then + -- refine result type, then do tcResult + { the_app' <- tcArgs fun fun' args expected_arg_tys + ; 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']) + ; returnM (co_fn <$> the_app') } + } + +-- Note [Push result type in] +-- +-- Unify with expected result before (was: after) type-checking the args +-- so that the info from res_ty (was: args) percolates to args (was actual_res_ty). +-- This is when we might detect a too-few args situation. +-- (One can think of cases when the opposite order would give +-- a better error message.) +-- [March 2003: I'm experimenting with putting this first. Here's an +-- example where it actually makes a real difference +-- class C t a b | t a -> b +-- instance C Char a Bool +-- +-- data P t a = forall b. (C t a b) => MkP b +-- data Q t = MkQ (forall a. P t a) - -- Now typecheck the args - mappM (tcArg fun) - (zip3 args expected_arg_tys [1..]) `thenM` \ args' -> +-- f1, f2 :: Q Char; +-- f1 = MkQ (MkP True) +-- f2 = MkQ (MkP True :: forall a. P Char a) +-- +-- With the change, f1 will type-check, because the 'Char' info from +-- the signature is propagated into MkQ's argument. With the check +-- in the other order, the extra signature in f2 is reqd.] + +---------------- +tcFun :: LHsExpr Name -> TcM (LHsExpr TcId, [TcTyVar], TcRhoType) +-- Instantiate the function, returning the type variables used +-- 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 (OccurrenceOf f) f + ; return (L loc fun', tvs, fun_tau) } +tcFun fun = do { (fun', fun_tau) <- tcInfer (tcMonoExpr fun) + ; return (fun', [], fun_tau) } + +---------------- +tcArgs :: LHsExpr Name -- The function (for error messages) + -> LHsExpr TcId -- The function (to build into result) + -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types + -> TcM (HsExpr TcId) -- Resulting application + +tcArgs fun fun' args expected_arg_tys + = do { args' <- mappM (tcArg fun) (zip3 args expected_arg_tys [1..]) + ; return (unLoc (foldl mkHsApp fun' args')) } - returnM (co_fn <$> unLoc (foldl mkHsApp fun' args')) +tcArg :: LHsExpr Name -- The function (for error messages) + -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type + -> TcM (LHsExpr TcId) -- Resulting argument +tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) + (tcCheckSigma arg ty) +---------------- +tcResult fun args res_ty actual_res_ty + = addErrCtxtM (checkArgsCtxt fun args res_ty actual_res_ty) + (tcSubExp res_ty actual_res_ty) +---------------- -- If an error happens we try to figure out whether the -- function has been given too many or too few arguments, -- and say so. -- The ~(Check...) is because in the Infer case the tcSubExp -- definitely won't fail, so we can be certain we're in the Check branch -checkArgsCtxt fun args ~(Check expected_res_ty) actual_res_ty tidy_env +checkArgsCtxt fun args (Infer _) actual_res_ty tidy_env + = return (tidy_env, ptext SLIT("Urk infer")) + +checkArgsCtxt fun args (Check expected_res_ty) actual_res_ty tidy_env = zonkTcType expected_res_ty `thenM` \ exp_ty' -> zonkTcType actual_res_ty `thenM` \ act_ty' -> let @@ -672,30 +737,19 @@ checkArgsCtxt fun args ~(Check expected_res_ty) actual_res_ty tidy_env in returnM (env2, message) - -split_fun_ty :: TcRhoType -- The type of the function - -> Int -- Number of arguments - -> TcM ([TcType], -- Function argument types - TcType) -- Function result types - -split_fun_ty fun_ty 0 - = returnM ([], fun_ty) - -split_fun_ty fun_ty n - = -- Expect the function to have type A->B - unifyFunTy fun_ty `thenM` \ (arg_ty, res_ty) -> - split_fun_ty res_ty (n-1) `thenM` \ (arg_tys, final_res_ty) -> - returnM (arg_ty:arg_tys, final_res_ty) -\end{code} - -\begin{code} -tcArg :: LHsExpr Name -- The function (for error messages) - -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type - -> TcM (LHsExpr TcId) -- Resulting argument - -tcArg the_fun (arg, expected_arg_ty, arg_no) - = addErrCtxt (funAppCtxt the_fun arg arg_no) $ - tcCheckSigma arg expected_arg_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 + 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} @@ -728,85 +782,107 @@ This gets a bit less sharing, but b) perhaps fewer separated lambdas \begin{code} -tcId :: Name -> TcM (HsExpr TcId, TcRhoType) -tcId name -- Look up the Id and instantiate its type - = -- First check whether it's a DataCon - -- Reason: we must not forget to chuck in the - -- constraints from their "silly context" - tcLookup name `thenM` \ thing -> +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 orig id_name -- Look up the Id and instantiate its type + = tcLookup id_name `thenM` \ thing -> case thing of { - AGlobal (ADataCon data_con) -> inst_data_con data_con - ; AGlobal (AnId id) -> loop (HsVar id) (idType id) + 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) } + + ; 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 proc_level -> tc_local_id id th_level proc_level - ; other -> pprPanic "tcId" (ppr name $$ ppr thing) + ; ATcId id th_level -> tc_local_id id th_level + + ; other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected")) } where #ifndef GHCI - tc_local_id id th_bind_lvl proc_lvl -- Non-TH case - = checkProcLevel id proc_lvl `thenM_` - loop (HsVar id) (idType id) + tc_local_id id th_bind_lvl -- Non-TH case + = instantiate id #else /* GHCI and TH is on */ - tc_local_id id th_bind_lvl proc_lvl -- TH case - = checkProcLevel id proc_lvl `thenM_` - - -- Check for cross-stage lifting + tc_local_id id th_bind_lvl -- TH case + = -- Check for cross-stage lifting getStage `thenM` \ use_stage -> 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_` - loop (HsVar id) (idType id) + instantiate id #endif /* GHCI */ - loop (HsVar fun_id) fun_ty + instantiate :: TcId -> TcM (HsExpr TcId, [TcTyVar], TcRhoType) + instantiate fun_id = loop (HsVar fun_id) [] (idType fun_id) + + loop (HsVar fun_id) tvs fun_ty | want_method_inst fun_ty - = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) -> + = tcInstType fun_ty `thenM` \ (tyvars, theta, tau) -> newMethodWithGivenTy orig fun_id (mkTyVarTys tyvars) theta tau `thenM` \ meth_id -> - loop (HsVar meth_id) tau + loop (HsVar meth_id) (tvs ++ tyvars) tau - loop fun fun_ty + loop fun tvs fun_ty | isSigmaTy fun_ty - = tcInstCall orig fun_ty `thenM` \ (inst_fn, tau) -> - loop (inst_fn <$> fun) tau + = tcInstCall orig fun_ty `thenM` \ (inst_fn, new_tvs, tau) -> + loop (inst_fn <$> fun) (tvs ++ new_tvs) tau | otherwise - = returnM (fun, fun_ty) + = returnM (fun, tvs, fun_ty) -- Hack Alert (want_method_inst)! -- If f :: (%x :: T) => Int -> Int @@ -821,22 +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) - - - -- We treat data constructors differently, because we have to generate - -- constraints for their silly theta, which no longer appears in - -- the type of dataConWrapId (see note on "stupid context" in DataCon.lhs - -- It's dual to TcPat.tcConstructor - inst_data_con data_con - = tcInstDataCon orig data_con `thenM` \ (ty_args, ex_dicts, arg_tys, result_ty, _) -> - extendLIEs ex_dicts `thenM_` - getSrcSpanM `thenM` \ loc -> - returnM (unLoc (mkHsDictApp (mkHsTyApp (L loc (HsVar (dataConWrapId data_con))) ty_args) - (map instToId ex_dicts)), - mkFunTys arg_tys result_ty) - -- ToDo: nasty loc/unloc stuff here - - orig = OccurrenceOf name \end{code} %************************************************************************ @@ -864,39 +924,30 @@ 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 = mkTopTyVarSubst (tyConTyVars tycon) ty_args - - do_bind (L loc field_lbl_name, rhs) - = addErrCtxt (fieldCtxt field_lbl_name) $ - tcLookupId field_lbl_name `thenM` \ 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 - - tcCheckSigma rhs field_ty `thenM` \ rhs' -> - - returnM (L loc sel_id, rhs') + do_bind (L loc field_lbl, rhs) + | Just field_ty <- assocMaybe flds_w_tys field_lbl + = addErrCtxt (fieldCtxt field_lbl) $ + 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) where - field_names = map fieldLabelName (dataConFieldLabels data_con) + field_names = dataConFieldLabels data_con checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM () checkMissingFields data_con rbinds @@ -920,12 +971,12 @@ checkMissingFields data_con rbinds missing_s_fields = [ fl | (fl, str) <- field_info, isMarkedStrict str, - not (fieldLabelName fl `elem` field_names_used) + not (fl `elem` field_names_used) ] missing_ns_fields = [ fl | (fl, str) <- field_info, not (isMarkedStrict str), - not (fieldLabelName fl `elem` field_names_used) + not (fl `elem` field_names_used) ] field_names_used = recBindFields rbinds @@ -952,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} @@ -991,10 +1043,6 @@ caseCtxt expr caseScrutCtxt expr = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr) -exprSigCtxt expr - = hang (ptext SLIT("In the type signature of the expression:")) - 4 (ppr expr) - exprCtxt expr = hang (ptext SLIT("In the expression:")) 4 (ppr expr) @@ -1020,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)) @@ -1027,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")]