X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=a67d30e9d3fc73107e13c01b96486f419b47b28d;hb=6c3c61e070a52231887db1cdc3a35bec021dcf42;hp=e9afbf5845fe05eb0dade1a25b50c0df5de9a72f;hpb=b768e242a4934facfd73f24dacd7ef854f85211d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index e9afbf5..a67d30e 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -4,73 +4,69 @@ \section[TcExpr]{Typecheck an expression} \begin{code} -module TcExpr ( tcExpr, tcExpr_id, tcMonoExpr ) where +module TcExpr ( tcCheckSigma, tcCheckRho, tcInferRho, tcMonoExpr ) where #include "HsVersions.h" #ifdef GHCI /* Only if bootstrapped */ import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) -import HsSyn ( HsReify(..), ReifyFlavour(..) ) -import TcType ( isTauTy ) -import TcEnv ( bracketOK, tcMetaTy, tcLookupGlobal, - wellStaged, metaLevel ) -import TcSimplify ( tcSimplifyBracket ) +import Id ( Id ) import Name ( isExternalName ) +import TcType ( isTauTy ) +import TcEnv ( checkWellStaged ) +import HsSyn ( nlHsApp ) import qualified DsMeta #endif -import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), recBindFields ) -import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds ) -import TcHsSyn ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, mkHsLet ) +import HsSyn ( HsExpr(..), LHsExpr, HsLit(..), ArithSeqInfo(..), recBindFields, + HsMatchContext(..), HsRecordBinds, mkHsApp, nlHsVar ) +import TcHsSyn ( hsLitType, (<$>) ) import TcRnMonad -import TcUnify ( tcSubExp, tcGen, (<$>), - unifyTauTy, unifyFunTy, unifyListTy, unifyPArrTy, - unifyTupleTy ) +import TcUnify ( Expected(..), tcInfer, zapExpectedType, zapExpectedTo, tcSubExp, tcGen, + unifyFunTys, zapToListTy, zapToTyConApp ) import BasicTypes ( isMarkedStrict ) -import Inst ( InstOrigin(..), - newOverloadedLit, newMethodFromName, newIPDict, - newDicts, newMethodWithGivenTy, - instToId, tcInstCall, tcInstDataCon - ) +import Inst ( newOverloadedLit, newMethodFromName, newIPDict, + newDicts, newMethodWithGivenTy, tcInstStupidTheta, tcInstCall ) import TcBinds ( tcBindsAndThen ) -import TcEnv ( tcLookupClass, tcLookupGlobal_maybe, tcLookupIdLvl, - tcLookupTyCon, tcLookupDataCon, tcLookupId +import TcEnv ( tcLookup, tcLookupId, checkProcLevel, + tcLookupDataCon, tcLookupGlobalId ) -import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts ) -import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) -import TcPat ( badFieldCon ) -import TcMType ( tcInstTyVars, tcInstType, newHoleTyVarTy, zapToType, - newTyVarTy, newTyVarTys, zonkTcType, readHoleResult ) -import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv), +import TcArrows ( tcProc ) +import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMatchCtxt(..) ) +import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) +import TcPat ( badFieldCon, refineTyVars ) +import TcMType ( tcInstTyVars, tcInstType, newTyFlexiVarTy, zonkTcType ) +import TcType ( Type, TcTyVar, TcType, TcSigmaType, TcRhoType, tcSplitFunTys, tcSplitTyConApp, mkTyVarTys, - isSigmaTy, mkFunTy, mkFunTys, - mkTyConApp, mkClassPred, tcFunArgTy, - tyVarsOfTypes, isLinearPred, - liftedTypeKind, openTypeKind, - tcSplitSigmaTy, tcTyConAppTyCon, - tidyOpenType + isSigmaTy, mkFunTy, mkTyConApp, tyVarsOfTypes, isLinearPred, + tcSplitSigmaTy, tidyOpenType ) -import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon ) -import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector, isDataConWrapId_maybe ) -import DataCon ( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks ) +import Kind ( openTypeKind, liftedTypeKind, argTypeKind ) + +import Id ( idType, recordSelectorFieldLabel, isRecordSelector ) +import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConWrapId ) import Name ( Name ) -import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons ) -import Subst ( mkTopTyVarSubst, substTheta, substTy ) +import TyCon ( TyCon, FieldLabel, tyConTyVars, tyConStupidTheta, + tyConDataCons, tyConFields ) +import Type ( zipTopTvSubst, substTheta, substTy ) +import Var ( tyVarKind ) import VarSet ( emptyVarSet, elemVarSet ) -import TysWiredIn ( boolTy ) -import PrelNames ( cCallableClassName, cReturnableClassName, - enumFromName, enumFromThenName, +import TysWiredIn ( boolTy, parrTyCon, tupleTyCon ) +import PrelNames ( enumFromName, enumFromThenName, enumFromToName, enumFromThenToName, - enumFromToPName, enumFromThenToPName, - ioTyConName + enumFromToPName, enumFromThenToPName ) import ListSetOps ( minusList ) import CmdLineOpts import HscTypes ( TyThing(..) ) - +import SrcLoc ( Located(..), unLoc, getLoc ) import Util import Outputable import FastString + +#ifdef DEBUG +import TyCon ( isAlgTyCon ) +#endif \end{code} %************************************************************************ @@ -80,51 +76,74 @@ import FastString %************************************************************************ \begin{code} -tcExpr :: RenamedHsExpr -- Expession to type check - -> TcSigmaType -- Expected type (could be a polytpye) - -> TcM TcExpr -- Generalised expr with expected type +-- tcCheckSigma does type *checking*; it's passed the expected type of the result +tcCheckSigma :: LHsExpr Name -- Expession to type check + -> TcSigmaType -- Expected type (could be a polytpye) + -> TcM (LHsExpr TcId) -- Generalised expr with expected type -tcExpr expr expected_ty +tcCheckSigma expr expected_ty = traceTc (text "tcExpr" <+> (ppr expected_ty $$ ppr expr)) `thenM_` tc_expr' expr expected_ty -tc_expr' expr expected_ty - | not (isSigmaTy expected_ty) -- Monomorphic case - = tcMonoExpr expr expected_ty - - | otherwise - = tcGen expected_ty emptyVarSet ( - tcMonoExpr expr +tc_expr' expr sigma_ty + | isSigmaTy sigma_ty + = tcGen sigma_ty emptyVarSet ( + \ rho_ty -> tcCheckRho expr rho_ty ) `thenM` \ (gen_fn, expr') -> - returnM (gen_fn <$> expr') + returnM (L (getLoc expr') (gen_fn <$> unLoc expr')) + +tc_expr' expr rho_ty -- Monomorphic case + = tcCheckRho expr rho_ty +\end{code} + +Typecheck expression which in most cases will be an Id. +The expression can return a higher-ranked type, such as + (forall a. a->a) -> Int +so we must create a hole to pass in as the expected tyvar. + +\begin{code} +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)) = setSrcSpan loc $ do + { (e,_,ty) <- tcId name; return (L loc e, ty)} +tcInferRho expr = tcInfer (tcMonoExpr expr) \end{code} + %************************************************************************ %* * -\subsection{The TAUT rules for variables} +\subsection{The TAUT rules for variables}TcExpr %* * %************************************************************************ \begin{code} -tcMonoExpr :: RenamedHsExpr -- Expession to type check - -> TcRhoType -- Expected type (could be a type variable) +tcMonoExpr :: LHsExpr Name -- Expession to type check + -> Expected TcRhoType -- Expected type (could be a type variable) -- Definitely no foralls at the top -- Can be a 'hole'. - -> TcM TcExpr + -> TcM (LHsExpr TcId) -tcMonoExpr (HsVar name) res_ty - = tcId name `thenM` \ (expr', id_ty) -> - tcSubExp res_ty id_ty `thenM` \ co_fn -> - returnM (co_fn <$> expr') +tcMonoExpr (L loc expr) res_ty + = setSrcSpan loc (do { expr' <- tc_expr expr res_ty + ; return (L loc expr') }) -tcMonoExpr (HsIPVar ip) res_ty +tc_expr :: HsExpr Name -> Expected TcRhoType -> TcM (HsExpr TcId) +tc_expr (HsVar name) res_ty + = do { (expr', _, id_ty) <- tcId name + ; co_fn <- tcSubExp res_ty id_ty + ; returnM (co_fn <$> expr') } + +tc_expr (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 -> - newIPDict (IPOcc ip) ip ip_ty `thenM` \ (ip', inst) -> + 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 -> returnM (co_fn <$> HsIPVar ip') @@ -138,20 +157,13 @@ tcMonoExpr (HsIPVar ip) res_ty %************************************************************************ \begin{code} -tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty - = addErrCtxt (exprSigCtxt in_expr) $ - tcHsSigType ExprSigCtxt poly_ty `thenM` \ sig_tc_ty -> - tcExpr expr sig_tc_ty `thenM` \ expr' -> - - -- Must instantiate the outer for-alls of sig_tc_ty - -- else we risk instantiating a ? res_ty to a forall-type - -- which breaks the invariant that tcMonoExpr only returns phi-types - tcInstCall SignatureOrigin sig_tc_ty `thenM` \ (inst_fn, inst_sig_ty) -> - tcSubExp res_ty inst_sig_ty `thenM` \ co_fn -> +tc_expr 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) - returnM (co_fn <$> inst_fn expr') - -tcMonoExpr (HsType ty) res_ty +tc_expr (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) @@ -168,23 +180,32 @@ tcMonoExpr (HsType ty) res_ty %************************************************************************ \begin{code} -tcMonoExpr (HsLit lit) res_ty = tcLit lit res_ty -tcMonoExpr (HsOverLit lit) res_ty = newOverloadedLit (LiteralOrigin lit) lit res_ty -tcMonoExpr (HsPar expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> - returnM (HsPar expr') -tcMonoExpr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> - returnM (HsSCC lbl expr') - - -tcMonoExpr (NegApp expr neg_name) res_ty - = tcMonoExpr (HsApp (HsVar neg_name) expr) res_ty +tc_expr (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' -> + returnM (HsSCC lbl expr') +tc_expr (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 + +tc_expr (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 + 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 -tcMonoExpr (HsLam match) res_ty +tc_expr (HsLam match) res_ty = tcMatchLambda match res_ty `thenM` \ match' -> returnM (HsLam match') -tcMonoExpr (HsApp e1 e2) res_ty +tc_expr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty \end{code} @@ -199,9 +220,9 @@ a type error will occur if they aren't. -- or just -- op e -tcMonoExpr in_expr@(SectionL arg1 op) res_ty - = tcExpr_id op `thenM` \ (op', op_ty) -> - split_fun_ty op_ty 2 {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) -> +tc_expr 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) -> tcArg op (arg1, arg1_ty, 1) `thenM` \ arg1' -> addErrCtxt (exprCtxt in_expr) $ tcSubExp res_ty (mkFunTy arg2_ty op_res_ty) `thenM` \ co_fn -> @@ -210,9 +231,9 @@ tcMonoExpr in_expr@(SectionL arg1 op) res_ty -- Right sections, equivalent to \ x -> x op expr, or -- \ x -> op x expr -tcMonoExpr in_expr@(SectionR op arg2) res_ty - = tcExpr_id op `thenM` \ (op', op_ty) -> - split_fun_ty op_ty 2 {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) -> +tc_expr 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) -> tcArg op (arg2, arg2_ty, 2) `thenM` \ arg2' -> addErrCtxt (exprCtxt in_expr) $ tcSubExp res_ty (mkFunTy arg1_ty op_res_ty) `thenM` \ co_fn -> @@ -220,9 +241,9 @@ tcMonoExpr in_expr@(SectionR op arg2) res_ty -- equivalent to (op e1) e2: -tcMonoExpr in_expr@(OpApp arg1 op fix arg2) res_ty - = tcExpr_id op `thenM` \ (op', op_ty) -> - split_fun_ty op_ty 2 {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) -> +tc_expr 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) -> tcArg op (arg1, arg1_ty, 1) `thenM` \ arg1' -> tcArg op (arg2, arg2_ty, 2) `thenM` \ arg2' -> addErrCtxt (exprCtxt in_expr) $ @@ -231,144 +252,86 @@ tcMonoExpr in_expr@(OpApp arg1 op fix arg2) res_ty \end{code} \begin{code} -tcMonoExpr (HsLet binds expr) res_ty +tc_expr (HsLet binds (L loc expr)) res_ty = tcBindsAndThen - HsLet + glue binds -- Bindings to check - (tcMonoExpr expr res_ty) - -tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty - = addSrcLoc src_loc $ - addErrCtxt (caseCtxt in_expr) $ + (setSrcSpan loc $ tc_expr expr res_ty) + where + glue bind expr = HsLet [bind] (L loc expr) - -- Typecheck the case alternatives first. +tc_expr 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 -- - -- Not only that, but it's better to check the matches on their - -- own, so that we get the expected results for scoped type variables. - -- f x = case x of - -- (p::a, q::b) -> (q,p) - -- The above should work: the match (p,q) -> (q,p) is polymorphic as - -- claimed by the pattern signatures. But if we typechecked the - -- match with x in scope and x's type as the expected type, we'd be hosed. - - tcMatchesCase matches res_ty `thenM` \ (scrut_ty, matches') -> - - addErrCtxt (caseScrutCtxt scrut) ( - tcMonoExpr scrut scrut_ty - ) `thenM` \ scrut' -> - - returnM (HsCase scrut' matches' src_loc) - -tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty - = addSrcLoc src_loc $ - addErrCtxt (predCtxt pred) ( - tcMonoExpr pred boolTy ) `thenM` \ pred' -> - - zapToType res_ty `thenM` \ res_ty' -> + -- 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' -> + + zapExpectedType res_ty openTypeKind `thenM` \ res_ty' -> -- C.f. the call to zapToType in TcMatches.tcMatches - tcMonoExpr b1 res_ty' `thenM` \ b1' -> - tcMonoExpr b2 res_ty' `thenM` \ b2' -> - returnM (HsIf pred' b1' b2' src_loc) + tcCheckRho b1 res_ty' `thenM` \ b1' -> + tcCheckRho b2 res_ty' `thenM` \ b2' -> + returnM (HsIf pred' b1' b2') -tcMonoExpr (HsDo do_or_lc stmts method_names _ src_loc) res_ty - = addSrcLoc src_loc $ - tcDoStmts do_or_lc stmts method_names res_ty `thenM` \ (binds, stmts', methods') -> - returnM (mkHsLet binds (HsDo do_or_lc stmts' methods' res_ty src_loc)) +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') -tcMonoExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list - = unifyListTy res_ty `thenM` \ elt_ty -> +tc_expr 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') where tc_elt elt_ty expr = addErrCtxt (listCtxt expr) $ - tcMonoExpr expr elt_ty + tcCheckRho expr elt_ty -tcMonoExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty - = unifyPArrTy res_ty `thenM` \ elt_ty -> - mappM (tc_elt elt_ty) exprs `thenM` \ exprs' -> - returnM (ExplicitPArr elt_ty exprs') +tc_expr 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) $ - tcMonoExpr expr elt_ty + = addErrCtxt (parrCtxt expr) (tcCheckRho expr elt_ty) -tcMonoExpr (ExplicitTuple exprs boxity) res_ty - = unifyTupleTy boxity (length exprs) res_ty `thenM` \ arg_tys -> - tcMonoExprs exprs arg_tys `thenM` \ exprs' -> - returnM (ExplicitTuple exprs' boxity) -\end{code} +tc_expr (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 + = tcProc pat cmd res_ty `thenM` \ (pat', cmd') -> + returnM (HsProc pat' cmd') -%************************************************************************ -%* * - Foreign calls -%* * -%************************************************************************ - -The interesting thing about @ccall@ is that it is just a template -which we instantiate by filling in details about the types of its -argument and result (ie minimal typechecking is performed). So, the -basic story is that we allocate a load of type variables (to hold the -arg/result types); unify them with the args/result; and store them for -later use. - -\begin{code} -tcMonoExpr e0@(HsCCall lbl args may_gc is_casm ignored_fake_result_ty) res_ty - - = getDOpts `thenM` \ dflags -> +tc_expr e@(HsArrApp _ _ _ _ _) _ + = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e), + ptext SLIT("was found where an expression was expected")]) - checkTc (not (is_casm && dopt_HscLang dflags /= HscC)) - (vcat [text "_casm_ is only supported when compiling via C (-fvia-C).", - text "Either compile with -fvia-C, or, better, rewrite your code", - text "to use the foreign function interface. _casm_s are deprecated", - text "and support for them may one day disappear."]) - `thenM_` - - -- Get the callable and returnable classes. - tcLookupClass cCallableClassName `thenM` \ cCallableClass -> - tcLookupClass cReturnableClassName `thenM` \ cReturnableClass -> - tcLookupTyCon ioTyConName `thenM` \ ioTyCon -> - let - new_arg_dict (arg, arg_ty) - = newDicts (CCallOrigin (unpackFS lbl) (Just arg)) - [mkClassPred cCallableClass [arg_ty]] `thenM` \ arg_dicts -> - returnM arg_dicts -- Actually a singleton bag - - result_origin = CCallOrigin (unpackFS lbl) Nothing {- Not an arg -} - in - - -- Arguments - let tv_idxs | null args = [] - | otherwise = [1..length args] - in - newTyVarTys (length tv_idxs) openTypeKind `thenM` \ arg_tys -> - tcMonoExprs args arg_tys `thenM` \ args' -> - - -- The argument types can be unlifted or lifted; the result - -- type must, however, be lifted since it's an argument to the IO - -- type constructor. - newTyVarTy liftedTypeKind `thenM` \ result_ty -> - let - io_result_ty = mkTyConApp ioTyCon [result_ty] - in - unifyTauTy res_ty io_result_ty `thenM_` - - -- Construct the extra insts, which encode the - -- constraints on the argument and result types. - mappM new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenM` \ ccarg_dicts_s -> - newDicts result_origin [mkClassPred cReturnableClass [result_ty]] `thenM` \ ccres_dict -> - extendLIEs (ccres_dict ++ concat ccarg_dicts_s) `thenM_` - returnM (HsCCall lbl args' may_gc is_casm io_result_ty) +tc_expr e@(HsArrForm _ _ _) _ + = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e), + ptext SLIT("was found where an expression was expected")]) \end{code} - %************************************************************************ %* * Record construction and update @@ -376,19 +339,19 @@ tcMonoExpr e0@(HsCCall lbl args may_gc is_casm ignored_fake_result_ty) res_ty %************************************************************************ \begin{code} -tcMonoExpr expr@(RecordCon con_name rbinds) res_ty +tc_expr expr@(RecordCon con@(L loc con_name) rbinds) res_ty = addErrCtxt (recordConCtxt expr) $ - tcId con_name `thenM` \ (con_expr, con_tau) -> + addLocM tcId con `thenM` \ (con_expr, _, con_tau) -> let (_, record_ty) = tcSplitFunTys con_tau (tycon, ty_args) = tcSplitTyConApp record_ty in ASSERT( isAlgTyCon tycon ) - unifyTauTy res_ty record_ty `thenM_` + zapExpectedTo res_ty record_ty `thenM_` -- Check that the record bindings match the constructor -- con_name is syntactically constrained to be a data constructor - tcLookupDataCon con_name `thenM` \ data_con -> + tcLookupDataCon con_name `thenM` \ data_con -> let bad_fields = badFields rbinds data_con in @@ -403,7 +366,7 @@ tcMonoExpr expr@(RecordCon con_name rbinds) res_ty -- Check for missing fields checkMissingFields data_con rbinds `thenM_` - returnM (RecordConOut data_con con_expr rbinds') + returnM (RecordConOut data_con (L loc con_expr) rbinds') -- The main complication with RecordUpd is that we need to explicitly -- handle the *non-updated* fields. Consider: @@ -431,22 +394,22 @@ tcMonoExpr expr@(RecordCon con_name rbinds) res_ty -- -- All this is done in STEP 4 below. -tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty +tc_expr expr@(RecordUpd record_expr rbinds) res_ty = addErrCtxt (recordUpdCtxt expr) $ -- STEP 0 -- Check that the field names are really field names ASSERT( notNull rbinds ) let - field_names = recBindFields rbinds + field_names = map fst rbinds in - mappM tcLookupGlobal_maybe field_names `thenM` \ maybe_sel_ids -> + mappM (tcLookupGlobalId.unLoc) field_names `thenM` \ sel_ids -> + -- The renamer has already checked that they + -- are all in scope let - bad_guys = [ addErrTc (notSelector field_name) - | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids, - case maybe_sel_id of - Just (AnId sel_id) -> not (isRecordSelector sel_id) - other -> True + 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 ] in checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM) `thenM_` @@ -455,22 +418,18 @@ tcMonoExpr 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) - (Just (AnId sel_id) : _) = maybe_sel_ids - - (_, _, tau) = tcSplitSigmaTy (idType sel_id) -- Selectors can be overloaded - -- when the data type has a context - data_ty = tcFunArgTy tau -- Must succeed since sel_id is a selector - tycon = tcTyConAppTyCon data_ty - data_cons = tyConDataCons tycon + 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 VanillaTv tycon_tyvars `thenM` \ (_, result_inst_tys, inst_env) -> + 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) - (badFieldsUpd rbinds) `thenM_` + (badFieldsUpd rbinds) `thenM_` -- STEP 3 -- Typecheck the update bindings. @@ -479,7 +438,7 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty let result_record_ty = mkTyConApp tycon result_inst_tys in - unifyTauTy res_ty result_record_ty `thenM_` + zapExpectedTo res_ty result_record_ty `thenM_` tcRecordBinds tycon result_inst_tys rbinds `thenM` \ rbinds' -> -- STEP 4 @@ -489,7 +448,7 @@ tcMonoExpr 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') + upd_field_lbls = recBindFields rbinds con_field_lbls_s = map dataConFieldLabels data_cons -- A constructor is only relevant to this process if @@ -498,20 +457,22 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty 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) + 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 (tyvar, result_inst_ty) - | tyvar `elemVarSet` common_tyvars = returnM result_inst_ty -- Same as result type - | otherwise = newTyVarTy liftedTypeKind -- Fresh type + 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 - mappM mk_inst_ty (zip tycon_tyvars result_inst_tys) `thenM` \ inst_tys -> + zipWithM mk_inst_ty tycon_tyvars result_inst_tys `thenM` \ inst_tys -> -- STEP 5 -- Typecheck the expression to be updated let record_ty = mkTyConApp tycon inst_tys in - tcMonoExpr record_expr record_ty `thenM` \ record_expr' -> + tcCheckRho record_expr record_ty `thenM` \ record_expr' -> -- STEP 6 -- Figure out the LIE we need. We have to generate some @@ -521,7 +482,7 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty -- What dictionaries do we need? -- We just take the context of the type constructor let - theta' = substTheta inst_env (tyConTheta tycon) + theta' = substTheta inst_env (tyConStupidTheta tycon) in newDicts RecordUpdOrigin theta' `thenM` \ dicts -> extendLIEs dicts `thenM_` @@ -540,69 +501,69 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty %************************************************************************ \begin{code} -tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty - = unifyListTy res_ty `thenM` \ elt_ty -> - tcMonoExpr expr elt_ty `thenM` \ expr' -> +tc_expr (ArithSeqIn 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 (HsVar enum_from) (From expr')) + returnM (ArithSeqOut (nlHsVar enum_from) (From expr')) -tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty +tc_expr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty = addErrCtxt (arithSeqCtxt in_expr) $ - unifyListTy res_ty `thenM` \ elt_ty -> - tcMonoExpr expr1 elt_ty `thenM` \ expr1' -> - tcMonoExpr expr2 elt_ty `thenM` \ expr2' -> + zapToListTy res_ty `thenM` \ elt_ty -> + tcCheckRho expr1 elt_ty `thenM` \ expr1' -> + tcCheckRho expr2 elt_ty `thenM` \ expr2' -> newMethodFromName (ArithSeqOrigin seq) elt_ty enumFromThenName `thenM` \ enum_from_then -> - returnM (ArithSeqOut (HsVar enum_from_then) (FromThen expr1' expr2')) + returnM (ArithSeqOut (nlHsVar enum_from_then) (FromThen expr1' expr2')) -tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty +tc_expr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty = addErrCtxt (arithSeqCtxt in_expr) $ - unifyListTy res_ty `thenM` \ elt_ty -> - tcMonoExpr expr1 elt_ty `thenM` \ expr1' -> - tcMonoExpr expr2 elt_ty `thenM` \ expr2' -> + zapToListTy res_ty `thenM` \ elt_ty -> + tcCheckRho expr1 elt_ty `thenM` \ expr1' -> + tcCheckRho expr2 elt_ty `thenM` \ expr2' -> newMethodFromName (ArithSeqOrigin seq) elt_ty enumFromToName `thenM` \ enum_from_to -> - returnM (ArithSeqOut (HsVar enum_from_to) (FromTo expr1' expr2')) + returnM (ArithSeqOut (nlHsVar enum_from_to) (FromTo expr1' expr2')) -tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty +tc_expr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty = addErrCtxt (arithSeqCtxt in_expr) $ - unifyListTy res_ty `thenM` \ elt_ty -> - tcMonoExpr expr1 elt_ty `thenM` \ expr1' -> - tcMonoExpr expr2 elt_ty `thenM` \ expr2' -> - tcMonoExpr expr3 elt_ty `thenM` \ expr3' -> + zapToListTy res_ty `thenM` \ elt_ty -> + tcCheckRho expr1 elt_ty `thenM` \ expr1' -> + tcCheckRho expr2 elt_ty `thenM` \ expr2' -> + tcCheckRho expr3 elt_ty `thenM` \ expr3' -> newMethodFromName (ArithSeqOrigin seq) elt_ty enumFromThenToName `thenM` \ eft -> - returnM (ArithSeqOut (HsVar eft) (FromThenTo expr1' expr2' expr3')) + returnM (ArithSeqOut (nlHsVar eft) (FromThenTo expr1' expr2' expr3')) -tcMonoExpr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty +tc_expr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty = addErrCtxt (parrSeqCtxt in_expr) $ - unifyPArrTy res_ty `thenM` \ elt_ty -> - tcMonoExpr expr1 elt_ty `thenM` \ expr1' -> - tcMonoExpr expr2 elt_ty `thenM` \ expr2' -> + 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 (HsVar enum_from_to) (FromTo expr1' expr2')) + returnM (PArrSeqOut (nlHsVar enum_from_to) (FromTo expr1' expr2')) -tcMonoExpr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty +tc_expr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty = addErrCtxt (parrSeqCtxt in_expr) $ - unifyPArrTy res_ty `thenM` \ elt_ty -> - tcMonoExpr expr1 elt_ty `thenM` \ expr1' -> - tcMonoExpr expr2 elt_ty `thenM` \ expr2' -> - tcMonoExpr expr3 elt_ty `thenM` \ expr3' -> + 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 (HsVar eft) (FromThenTo expr1' expr2' expr3')) + returnM (PArrSeqOut (nlHsVar eft) (FromThenTo expr1' expr2' expr3')) -tcMonoExpr (PArrSeqIn _) _ +tc_expr (PArrSeqIn _) _ = panic "TcExpr.tcMonoExpr: Infinite parallel array!" -- the parser shouldn't have generated it and the renamer shouldn't have -- let it through @@ -618,45 +579,10 @@ tcMonoExpr (PArrSeqIn _) _ \begin{code} #ifdef GHCI /* Only if bootstrapped */ -- Rename excludes these cases otherwise - -tcMonoExpr (HsSplice n expr loc) res_ty = addSrcLoc loc (tcSpliceExpr n expr res_ty) - -tcMonoExpr (HsBracket brack loc) res_ty - = addSrcLoc loc $ - getStage `thenM` \ level -> - case bracketOK level of { - Nothing -> failWithTc (illegalBracket level) ; - Just next_level -> - - -- Typecheck expr to make sure it is valid, - -- but throw away the results. We'll type check - -- it again when we actually use it. - newMutVar [] `thenM` \ pending_splices -> - getLIEVar `thenM` \ lie_var -> - - setStage (Brack next_level pending_splices lie_var) ( - getLIE (tcBracket brack) - ) `thenM` \ (meta_ty, lie) -> - tcSimplifyBracket lie `thenM_` - - unifyTauTy res_ty meta_ty `thenM_` - - -- Return the original expression, not the type-decorated one - readMutVar pending_splices `thenM` \ pendings -> - returnM (HsBracketOut brack pendings) - } - -tcMonoExpr (HsReify (Reify flavour name)) res_ty - = addErrCtxt (ptext SLIT("At the reification of") <+> ppr name) $ - tcMetaTy tycon_name `thenM` \ reify_ty -> - unifyTauTy res_ty reify_ty `thenM_` - returnM (HsReify (ReifyOut flavour name)) - where - tycon_name = case flavour of - ReifyDecl -> DsMeta.decTyConName - ReifyType -> DsMeta.typTyConName - ReifyFixity -> pprPanic "tcMonoExpr: cant do reifyFixity yet" (ppr name) -#endif GHCI +tc_expr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty +tc_expr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty + ; return (unLoc e) } +#endif /* GHCI */ \end{code} @@ -667,7 +593,7 @@ tcMonoExpr (HsReify (Reify flavour name)) res_ty %************************************************************************ \begin{code} -tcMonoExpr other _ = pprPanic "tcMonoExpr" (ppr other) +tc_expr other _ = pprPanic "tcMonoExpr" (ppr other) \end{code} @@ -679,41 +605,108 @@ tcMonoExpr other _ = pprPanic "tcMonoExpr" (ppr other) \begin{code} -tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args - -> TcType -- Expected result type of application - -> TcM TcExpr -- Translated fun and args +tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args + -> Expected TcRhoType -- Expected result type of application + -> TcM (HsExpr TcId) -- Translated fun and args -tcApp (HsApp e1 e2) args res_ty +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 - tcExpr_id 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) -> - - -- Now typecheck the args - mappM (tcArg fun) - (zip3 args expected_arg_tys [1..]) `thenM` \ args' -> - - -- Unify with expected result after type-checking the args - -- so that the info from args percolates to 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.) - addErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) - (tcSubExp res_ty actual_result_ty) `thenM` \ co_fn -> - - returnM (co_fn <$> foldl HsApp fun' args') - + = do { (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 } + + + ; 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) +-- 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 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')) } + +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 -checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env +-- 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 (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 @@ -730,31 +723,6 @@ checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env | otherwise = appCtxt fun args in returnM (env2, message) - - -split_fun_ty :: TcType -- 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 :: RenamedHsExpr -- The function (for error messages) - -> (RenamedHsExpr, TcSigmaType, Int) -- Actual argument and expected arg type - -> TcM TcExpr -- Resulting argument and LIE - -tcArg the_fun (arg, expected_arg_ty, arg_no) - = addErrCtxt (funAppCtxt the_fun arg arg_no) $ - tcExpr arg expected_arg_ty \end{code} @@ -787,80 +755,110 @@ This gets a bit less sharing, but b) perhaps fewer separated lambdas \begin{code} -tcId :: Name -> TcM (TcExpr, TcType) -tcId name -- Look up the Id and instantiate its type - = tcLookupIdLvl name `thenM` \ (id, bind_lvl) -> +tcId :: 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 id_name -- Look up the Id and instantiate its type + = tcLookup id_name `thenM` \ thing -> + case thing of { + 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) -> instantiate id + -- A global cannot possibly be ill-staged + -- nor does it need the 'lifting' treatment + + ; ATcId id th_level proc_level + -> do { checkProcLevel id proc_level + ; tc_local_id id th_level } + + -- THis + ; other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected")) + } + where - -- Check for cross-stage lifting -#ifdef GHCI - getStage `thenM` \ use_stage -> - case use_stage of - Brack use_lvl ps_var lie_var - | use_lvl > bind_lvl && not (isExternalName name) - -> -- E.g. \x -> [| h x |] - -- We must behave as if the reference to x was +#ifndef GHCI + 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 -- 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 + -> 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 - -- NB: isExernalName is true of top level things, - -- and false of nested bindings - - 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, HsApp (HsVar lift) (HsVar id)) : ps) `thenM_` - - returnM (HsVar id, id_ty)) - - other -> - let - use_lvl = metaLevel use_stage - in - checkTc (wellStaged bind_lvl use_lvl) - (badStageErr id bind_lvl use_lvl) `thenM_` -#endif - -- This is the bit that handles the no-Template-Haskell case - case isDataConWrapId_maybe id of - Nothing -> loop (HsVar id) (idType id) - Just data_con -> inst_data_con id data_con - - where - orig = OccurrenceOf name - - loop (HsVar fun_id) fun_ty + -- 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_` + instantiate id +#endif /* GHCI */ + + 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) - want_method_inst fun_ty - | opt_NoMethodSharing = False - | otherwise = case tcSplitSigmaTy fun_ty of - (_,[],_) -> False -- Not overloaded - (_,theta,_) -> not (any isLinearPred theta) - -- This is a slight hack. + -- Hack Alert (want_method_inst)! -- If f :: (%x :: T) => Int -> Int -- Then if we have two separate calls, (f 3, f 4), we cannot -- make a method constraint that then gets shared, thus: @@ -868,32 +866,15 @@ tcId name -- Look up the Id and instantiate its type -- because that loses the linearity of the constraint. -- The simplest thing to do is never to construct a method constraint -- in the first place that has a linear implicit parameter in it. + want_method_inst fun_ty + | opt_NoMethodSharing = False + | 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. It's dual to TcPat.tcConstructor - inst_data_con id data_con - = tcInstDataCon orig data_con `thenM` \ (ty_args, ex_dicts, arg_tys, result_ty, _) -> - extendLIEs ex_dicts `thenM_` - returnM (mkHsDictApp (mkHsTyApp (HsVar id) ty_args) (map instToId ex_dicts), - mkFunTys arg_tys result_ty) -\end{code} - -Typecheck expression which in most cases will be an Id. -The expression can return a higher-ranked type, such as - (forall a. a->a) -> Int -so we must create a HoleTyVarTy to pass in as the expected tyvar. - -\begin{code} -tcExpr_id :: RenamedHsExpr -> TcM (TcExpr, TcType) -tcExpr_id (HsVar name) = tcId name -tcExpr_id expr = newHoleTyVarTy `thenM` \ id_ty -> - tcMonoExpr expr id_ty `thenM` \ expr' -> - readHoleResult id_ty `thenM` \ id_ty' -> - returnM (expr', id_ty') + orig = OccurrenceOf id_name \end{code} - %************************************************************************ %* * \subsection{Record bindings} @@ -921,39 +902,39 @@ This extends OK when the field types are universally quantified. tcRecordBinds :: TyCon -- Type constructor for the record -> [TcType] -- Args of this type constructor - -> RenamedRecordBinds - -> TcM TcRecordBinds + -> HsRecordBinds Name + -> TcM (HsRecordBinds TcId) tcRecordBinds tycon ty_args rbinds = mappM do_bind rbinds where - tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args + tenv = zipTopTvSubst (tyConTyVars tycon) ty_args - do_bind (field_lbl_name, rhs) - = addErrCtxt (fieldCtxt field_lbl_name) $ - tcLookupId field_lbl_name `thenM` \ sel_id -> + do_bind (L loc field_lbl, rhs) + = addErrCtxt (fieldCtxt field_lbl) $ let - field_lbl = recordSelectorFieldLabel sel_id - field_ty = substTy tenv (fieldLabelType field_lbl) + 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 - ASSERT2( fieldLabelTyCon field_lbl == tycon, ppr field_lbl ) - -- The caller of tcRecordBinds has already checked - -- that all the fields come from the same type - - tcExpr rhs field_ty `thenM` \ rhs' -> - - returnM (sel_id, rhs') 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 -> RenamedRecordBinds -> TcM () +checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM () checkMissingFields data_con rbinds | null field_labels -- Not declared as a record; -- But C{} is still valid if no strict fields @@ -975,12 +956,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 @@ -990,25 +971,22 @@ checkMissingFields data_con rbinds field_labels field_strs - field_strs = dropList ex_theta (dataConStrictMarks data_con) - -- The 'drop' is because dataConStrictMarks - -- includes the existential dictionaries - (_, _, _, ex_theta, _, _) = dataConSig data_con + field_strs = dataConStrictMarks data_con \end{code} %************************************************************************ %* * -\subsection{@tcMonoExprs@ typechecks a {\em list} of expressions} +\subsection{@tcCheckRhos@ typechecks a {\em list} of expressions} %* * %************************************************************************ \begin{code} -tcMonoExprs :: [RenamedHsExpr] -> [TcType] -> TcM [TcExpr] +tcCheckRhos :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId] -tcMonoExprs [] [] = returnM [] -tcMonoExprs (expr:exprs) (ty:tys) - = tcMonoExpr expr ty `thenM` \ expr' -> - tcMonoExprs exprs tys `thenM` \ exprs' -> +tcCheckRhos [] [] = returnM [] +tcCheckRhos (expr:exprs) (ty:tys) + = tcCheckRho expr ty `thenM` \ expr' -> + tcCheckRhos exprs tys `thenM` \ exprs' -> returnM (expr':exprs') \end{code} @@ -1022,16 +1000,9 @@ tcMonoExprs (expr:exprs) (ty:tys) Overloaded literals. \begin{code} -tcLit :: HsLit -> TcType -> TcM TcExpr -tcLit (HsLitLit s _) res_ty - = tcLookupClass cCallableClassName `thenM` \ cCallableClass -> - newDicts (LitLitOrigin (unpackFS s)) - [mkClassPred cCallableClass [res_ty]] `thenM` \ dicts -> - extendLIEs dicts `thenM_` - returnM (HsLit (HsLitLit s res_ty)) - +tcLit :: HsLit -> Expected TcRhoType -> TcM (HsExpr TcId) tcLit lit res_ty - = unifyTauTy res_ty (hsLitType lit) `thenM_` + = zapExpectedTo res_ty (hsLitType lit) `thenM_` returnM (HsLit lit) \end{code} @@ -1047,12 +1018,6 @@ Boring and alphabetical: arithSeqCtxt expr = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr) - -badStageErr id bind_lvl use_lvl - = ptext SLIT("Stage error:") <+> quotes (ppr id) <+> - hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl, - ptext SLIT("but used at stage") <+> ppr use_lvl] - parrSeqCtxt expr = hang (ptext SLIT("In a parallel array sequence:")) 4 (ppr expr) @@ -1062,10 +1027,6 @@ caseCtxt expr caseScrutCtxt expr = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr) -exprSigCtxt expr - = hang (ptext SLIT("When checking the type signature of the expression:")) - 4 (ppr expr) - exprCtxt expr = hang (ptext SLIT("In the expression:")) 4 (ppr expr) @@ -1086,18 +1047,10 @@ parrCtxt expr predCtxt expr = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr) -illegalBracket level - = ptext SLIT("Illegal bracket at level") <+> ppr level - appCtxt fun args = ptext SLIT("In the application") <+> quotes (ppr the_app) where - the_app = foldl HsApp fun args -- Used in error messages - -lurkingRank2Err fun fun_ty - = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)]) - 4 (vcat [ptext SLIT("It is applied to too few arguments"), - ptext SLIT("so that the result type has for-alls in it:") <+> ppr fun_ty]) + the_app = foldl mkHsApp fun args -- Used in error messages badFieldsUpd rbinds = hang (ptext SLIT("No constructor has all these fields:")) @@ -1120,21 +1073,22 @@ missingStrictFields con fields header = ptext SLIT("Constructor") <+> quotes (ppr con) <+> ptext SLIT("does not have the required strict field(s)") - missingFields :: DataCon -> [FieldLabel] -> SDoc missingFields con fields = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:") <+> pprWithCommas ppr fields -polySpliceErr :: Id -> SDoc -polySpliceErr id - = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id) - wrongArgsCtxt too_many_or_few fun args = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun) <+> ptext SLIT("is applied to") <+> text too_many_or_few <+> ptext SLIT("arguments in the call")) 4 (parens (ppr the_app)) where - the_app = foldl HsApp fun args -- Used in error messages + the_app = foldl mkHsApp fun args -- Used in error messages + +#ifdef GHCI +polySpliceErr :: Id -> SDoc +polySpliceErr id + = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id) +#endif \end{code}