X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=86e8f0904a6b2db0339af14ffa8286ae76411fd2;hp=d6099816bf03709193dcda649464740d28f45677;hb=HEAD;hpb=c455d9a46cbe9b7fa0013a7bcadaa5c738944604 diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index d609981..86e8f09 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -1,91 +1,66 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcExpr]{Typecheck an expression} \begin{code} -module TcExpr ( tcPolyExpr, tcPolyExprNC, - tcMonoExpr, tcInferRho, tcSyntaxOp ) where +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + +module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, + tcInferRho, tcInferRhoNC, + tcSyntaxOp, tcCheckId, + addExprErrCtxt ) where #include "HsVersions.h" #ifdef GHCI /* Only if bootstrapped */ import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) -import HsSyn ( nlHsVar ) -import Id ( Id, idName ) -import Name ( isExternalName ) -import TcType ( isTauTy ) -import TcEnv ( checkWellStaged ) -import HsSyn ( nlHsApp ) import qualified DsMeta #endif -import HsSyn ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields, - HsMatchContext(..), HsRecordBinds, mkHsCoerce, - mkHsApp ) -import TcHsSyn ( hsLitType ) +import HsSyn +import TcHsSyn import TcRnMonad -import TcUnify ( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType, - boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, preSubType, - unBox ) -import BasicTypes ( Arity, isMarkedStrict ) -import Inst ( newMethodFromName, newIPDict, instCall, - newMethodWithGivenTy, instStupidTheta ) -import TcBinds ( tcLocalBinds ) -import TcEnv ( tcLookup, tcLookupDataCon, tcLookupField ) -import TcArrows ( tcProc ) -import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcBody, - TcMatchCtxt(..) ) -import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) -import TcPat ( tcOverloadedLit, addDataConStupidTheta, badFieldCon ) -import TcMType ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars, - readFilledBox, zonkTcTypes ) -import TcType ( TcType, TcSigmaType, TcRhoType, TvSubst, - BoxySigmaType, BoxyRhoType, ThetaType, - mkTyVarTys, mkFunTys, - tcMultiSplitSigmaTy, tcSplitFunTysN, - tcSplitTyConApp_maybe, - isSigmaTy, mkFunTy, mkTyConApp, isLinearPred, - exactTyVarsOfType, exactTyVarsOfTypes, - zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar - ) -import {- Kind parts of -} - Type ( argTypeKind ) - -import Id ( Id, idType, recordSelectorFieldLabel, - isRecordSelector, isNaughtyRecordSelector, - isDataConId_maybe ) -import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, - dataConSourceArity, - dataConWrapId, isVanillaDataCon, dataConUnivTyVars, - dataConOrigArgTys ) -import Name ( Name ) -import TyCon ( FieldLabel, tyConStupidTheta, tyConDataCons, - isEnumerationTyCon ) -import Type ( substTheta, substTy ) -import Var ( TyVar, tyVarKind ) -import VarSet ( emptyVarSet, elemVarSet, unionVarSet ) -import TysWiredIn ( boolTy, parrTyCon, tupleTyCon ) -import PrelNames ( enumFromName, enumFromThenName, - enumFromToName, enumFromThenToName, - enumFromToPName, enumFromThenToPName, negateName, - hasKey - ) -import PrimOp ( tagToEnumKey ) - +import TcUnify +import BasicTypes +import Inst +import TcBinds +import TcEnv +import TcArrows +import TcMatches +import TcHsType +import TcPat +import TcMType +import TcType +import Id +import DataCon +import Name +import TyCon +import Type +import TypeRep +import Coercion +import Var +import VarSet +import VarEnv +import TysWiredIn +import TysPrim( intPrimTy, ecKind ) +import PrimOp( tagToEnumKey ) +import PrelNames +import Module import DynFlags -import StaticFlags ( opt_NoMethodSharing ) -import HscTypes ( TyThing(..) ) -import SrcLoc ( Located(..), unLoc, getLoc ) +import SrcLoc import Util -import ListSetOps ( assocMaybe ) -import Maybes ( catMaybes ) +import ListSetOps +import Maybes +import ErrUtils import Outputable import FastString - -#ifdef DEBUG -import TyCon ( tyConArity ) -#endif +import Control.Monad \end{code} %************************************************************************ @@ -96,58 +71,68 @@ import TyCon ( tyConArity ) \begin{code} tcPolyExpr, tcPolyExprNC - :: LHsExpr Name -- Expession to type check - -> BoxySigmaType -- Expected type (could be a polytpye) + :: LHsExpr Name -- Expression to type check + -> TcSigmaType -- Expected type (could be a polytpye) -> TcM (LHsExpr TcId) -- Generalised expr with expected type --- tcPolyExpr is a convenient place (frequent but not too frequent) place --- to add context information. +-- tcPolyExpr is a convenient place (frequent but not too frequent) +-- place to add context information. -- The NC version does not do so, usually because the caller wants -- to do so himself. tcPolyExpr expr res_ty - = addErrCtxt (exprCtxt (unLoc expr)) $ - tcPolyExprNC expr res_ty + = addExprErrCtxt expr $ + do { traceTc "tcPolyExpr" (ppr res_ty); tcPolyExprNC expr res_ty } -tcPolyExprNC expr res_ty - | isSigmaTy res_ty - = do { (gen_fn, expr') <- tcGen res_ty emptyVarSet (tcPolyExprNC expr) - -- Note the recursive call to tcPolyExpr, because the - -- type may have multiple layers of for-alls - ; return (L (getLoc expr') (mkHsCoerce gen_fn (unLoc expr'))) } - - | otherwise - = tcMonoExpr expr res_ty +tcPolyExprNC expr res_ty + = do { traceTc "tcPolyExprNC" (ppr res_ty) + ; (gen_fn, expr') <- tcGen GenSigCtxt res_ty $ \ _ rho -> + tcMonoExprNC expr rho + ; return (mkLHsWrap gen_fn expr') } --------------- -tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId] -tcPolyExprs [] [] = returnM [] -tcPolyExprs (expr:exprs) (ty:tys) - = do { expr' <- tcPolyExpr expr ty - ; exprs' <- tcPolyExprs exprs tys - ; returnM (expr':exprs') } -tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys) +tcMonoExpr, tcMonoExprNC + :: LHsExpr Name -- Expression to type check + -> TcRhoType -- Expected type (could be a type variable) + -- Definitely no foralls at the top + -> TcM (LHsExpr TcId) ---------------- -tcMonoExpr :: LHsExpr Name -- Expression to type check - -> BoxyRhoType -- Expected type (could be a type variable) - -- Definitely no foralls at the top - -- Can contain boxes, which will be filled in - -> TcM (LHsExpr TcId) +tcMonoExpr expr res_ty + = addErrCtxt (exprCtxt expr) $ + tcMonoExprNC expr res_ty -tcMonoExpr (L loc expr) res_ty +tcMonoExprNC (L loc expr) res_ty = ASSERT( not (isSigmaTy res_ty) ) setSrcSpan loc $ do { expr' <- tcExpr expr res_ty ; return (L loc expr') } --------------- -tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) -tcInferRho expr = tcInfer (tcMonoExpr expr) +tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) +-- Infer a *rho*-type. This is, in effect, a special case +-- for ids and partial applications, so that if +-- f :: Int -> (forall a. a -> a) -> Int +-- then we can infer +-- f 3 :: (forall a. a -> a) -> Int +-- And that in turn is useful +-- (a) for the function part of any application (see tcApp) +-- (b) for the special rule for '$' +tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr) + +tcInferRhoNC (L loc expr) + = setSrcSpan loc $ + do { (expr', rho) <- tcInfExpr expr + ; return (L loc expr', rho) } + +tcInfExpr :: HsExpr Name -> TcM (HsExpr TcId, TcRhoType) +tcInfExpr (HsVar f) = tcInferId f +tcInfExpr (HsPar e) = do { (e', ty) <- tcInferRhoNC e + ; return (HsPar e', ty) } +tcInfExpr (HsApp e1 e2) = tcInferApp e1 [e2] +tcInfExpr e = tcInfer (tcExpr e) \end{code} - %************************************************************************ %* * tcExpr: the main expression typechecker @@ -155,64 +140,152 @@ tcInferRho expr = tcInfer (tcMonoExpr expr) %************************************************************************ \begin{code} -tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId) -tcExpr (HsVar name) res_ty = tcId (OccurrenceOf name) name res_ty - -tcExpr (HsLit lit) res_ty = do { boxyUnify (hsLitType lit) res_ty - ; return (HsLit lit) } - -tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; return (HsPar expr') } - -tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; returnM (HsSCC lbl expr') } -tcExpr (HsCoreAnn lbl expr) res_ty -- hdaume: core annotation +updHetMetLevel :: ([TyVar] -> [TyVar]) -> TcM a -> TcM a +updHetMetLevel f comp = + updEnv + (\oldenv -> let oldlev = (case oldenv of Env { env_lcl = e' } -> case e' of TcLclEnv { tcl_hetMetLevel = x } -> x) + in (oldenv { env_lcl = (env_lcl oldenv) { tcl_hetMetLevel = f oldlev } })) + + comp + +addEscapes :: [TyVar] -> HsExpr Name -> HsExpr Name +addEscapes [] e = e +addEscapes (t:ts) e = HsHetMetEsc (TyVarTy t) placeHolderType (noLoc (addEscapes ts e)) + +getIdLevel :: Name -> TcM [TyVar] +getIdLevel name + = do { thing <- tcLookup name + ; case thing of + ATcId { tct_hetMetLevel = variable_hetMetLevel } -> return $ variable_hetMetLevel + _ -> return [] + } + +tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId) +tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check + = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e) + +tcExpr (HsVar name) res_ty = tcCheckId name res_ty + +tcExpr (HsHetMetBrak _ e) res_ty = + do { (coi, [inferred_name,elt_ty]) <- matchExpectedTyConApp hetMetCodeTypeTyCon res_ty + ; fresh_ec_name <- newFlexiTyVar ecKind + ; expr' <- updHetMetLevel (\old_lev -> (fresh_ec_name:old_lev)) + $ tcPolyExpr e elt_ty + ; unifyType (TyVarTy fresh_ec_name) inferred_name + ; return $ mkHsWrapCo coi (HsHetMetBrak (TyVarTy fresh_ec_name) expr') } +tcExpr (HsHetMetEsc _ _ e) res_ty = + do { cur_level <- getHetMetLevel + ; expr' <- updHetMetLevel (\old_lev -> tail old_lev) + $ tcExpr (unLoc e) (mkTyConApp hetMetCodeTypeTyCon [(TyVarTy $ head cur_level),res_ty]) + ; ty' <- zonkTcType res_ty + ; return $ HsHetMetEsc (TyVarTy $ head cur_level) ty' (noLoc expr') } +tcExpr (HsHetMetCSP _ e) res_ty = + do { cur_level <- getHetMetLevel + ; expr' <- updHetMetLevel (\old_lev -> tail old_lev) + $ tcExpr (unLoc e) res_ty + ; return $ HsHetMetCSP (TyVarTy $ head cur_level) (noLoc expr') } + +tcExpr (HsKappa match) res_ty = + do { v1 <- newFlexiTyVar liftedTypeKind + ; v2 <- newFlexiTyVar liftedTypeKind + ; v3 <- newFlexiTyVar liftedTypeKind + ; (_, [ty_ab, ty_c]) <- matchExpectedTyConApp hetMetKappaTyCon res_ty + ; (_, [ty_a, ty_b]) <- matchExpectedTyConApp pairTyCon ty_ab + ; (co_fn, match') <- tcMatchLambda match (mkFunTy + (mkHetMetKappaTy unitTy ty_a) + (mkHetMetKappaTy ty_b ty_c)) + ; return (HsKappa match') } + +tcExpr (HsKappaApp e1 e2) res_ty = + do { v1 <- newFlexiTyVar liftedTypeKind + ; v2 <- newFlexiTyVar liftedTypeKind + ; v3 <- newFlexiTyVar liftedTypeKind + ; e1' <- tcExpr (unLoc e1) (mkHetMetKappaTy (mkTyConApp pairTyCon [(TyVarTy v1), (TyVarTy v2)]) (TyVarTy v3)) + ; e2' <- tcExpr (unLoc e2) (mkHetMetKappaTy unitTy (TyVarTy v1)) + ; unifyType res_ty (mkHetMetKappaTy (TyVarTy v2) (TyVarTy v3)) + ; return (HsKappaApp (noLoc e1') (noLoc e2')) } + +tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty + +tcExpr (HsLit lit) res_ty = + getHetMetLevel >>= \lev -> + case lev of + [] -> do { let lit_ty = hsLitType lit + ; tcWrapResult (HsLit lit) lit_ty res_ty } + (ec:rest) -> let n = case lit of + (HsChar c) -> hetmet_guest_char_literal_name + (HsString str) -> hetmet_guest_string_literal_name + (HsInteger i _) -> hetmet_guest_integer_literal_name + (HsInt i) -> hetmet_guest_integer_literal_name + _ -> error "literals of this sort are not allowed at depth >0" + in tcExpr (HsHetMetEsc (TyVarTy ec) placeHolderType $ noLoc $ + (HsApp (noLoc $ HsVar n) (noLoc $ HsLit lit))) res_ty + +tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty + ; return (HsPar expr') } + +tcExpr (HsSCC lbl expr) res_ty + = do { expr' <- tcMonoExpr expr res_ty + ; return (HsSCC lbl expr') } + +tcExpr (HsTickPragma info expr) res_ty + = do { expr' <- tcMonoExpr expr res_ty + ; return (HsTickPragma info expr') } + +tcExpr (HsCoreAnn lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty ; return (HsCoreAnn lbl expr') } -tcExpr (HsOverLit lit) res_ty - = do { lit' <- tcOverloadedLit (LiteralOrigin lit) lit res_ty - ; return (HsOverLit lit') } +tcExpr (HsOverLit lit) res_ty = + getHetMetLevel >>= \lev -> + case lev of + [] -> do { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty + ; return (HsOverLit lit') } + (ec:rest) -> let n = case lit of + (OverLit { ol_val = HsIntegral i }) -> hetmet_guest_integer_literal_name + (OverLit { ol_val = HsIsString fs }) -> hetmet_guest_string_literal_name + (OverLit { ol_val = HsFractional f }) -> error "fractional literals not allowed at depth >0" + in tcExpr (HsHetMetEsc (TyVarTy ec) placeHolderType $ noLoc $ + (HsApp (noLoc $ HsVar n) (noLoc $ HsOverLit lit))) res_ty + tcExpr (NegApp expr neg_expr) res_ty - = do { neg_expr' <- tcSyntaxOp (OccurrenceOf negateName) neg_expr + = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr (mkFunTy res_ty res_ty) ; expr' <- tcMonoExpr expr res_ty ; return (NegApp expr' neg_expr') } tcExpr (HsIPVar ip) res_ty - = do { -- Implicit parameters must have a *tau-type* not a + = do { let origin = IPOccOrigin ip + -- 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.) - ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple - ; co_fn <- tcSubExp ip_ty res_ty - ; (ip', inst) <- newIPDict (IPOccOrigin ip) ip ip_ty - ; extendLIE inst - ; return (mkHsCoerce co_fn (HsIPVar ip')) } - -tcExpr (HsApp e1 e2) res_ty - = go e1 [e2] - where - go :: LHsExpr Name -> [LHsExpr Name] -> TcM (HsExpr TcId) - go (L _ (HsApp e1 e2)) args = go e1 (e2:args) - go lfun@(L loc fun) args - = do { (fun', args') <- -- addErrCtxt (callCtxt lfun args) $ - tcApp fun (length args) (tcArgs lfun args) res_ty - ; return (unLoc (foldl mkHsApp (L loc fun') args')) } + ; ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple + ; ip_var <- emitWanted origin (mkIPPred ip ip_ty) + ; tcWrapResult (HsIPVar (IPName ip_var)) ip_ty res_ty } tcExpr (HsLam match) res_ty = do { (co_fn, match') <- tcMatchLambda match res_ty - ; return (mkHsCoerce co_fn (HsLam match')) } + ; return (mkHsWrap co_fn (HsLam match')) } + +tcExpr (ExprWithTySig expr sig_ty) res_ty + = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty + + -- Remember to extend the lexical type-variable environment + ; (gen_fn, expr') + <- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty -> + tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $ + -- See Note [More instantiated than scoped] in TcBinds + tcMonoExprNC expr res_ty -tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty - = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty - ; expr' <- tcPolyExpr expr sig_tc_ty - ; co_fn <- tcSubExp sig_tc_ty res_ty - ; return (mkHsCoerce co_fn (ExprWithTySigOut expr' sig_ty)) } + ; let inner_expr = ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty -tcExpr (HsType ty) res_ty + ; (inst_wrap, rho) <- deeplyInstantiate ExprSigOrigin sig_tc_ty + ; tcWrapResult (mkHsWrap inst_wrap inner_expr) rho res_ty } + +tcExpr (HsType 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) @@ -228,44 +301,156 @@ tcExpr (HsType ty) res_ty %* * %************************************************************************ +Note [Left sections] +~~~~~~~~~~~~~~~~~~~~ +Left sections, like (4 *), are equivalent to + \ x -> (*) 4 x, +or, if PostfixOperators is enabled, just + (*) 4 +With PostfixOperators we don't actually require the function to take +two arguments at all. For example, (x `not`) means (not x); you get +postfix operators! Not Haskell 98, but it's less work and kind of +useful. + +Note [Typing rule for ($)] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +People write + runST $ blah +so much, where + runST :: (forall s. ST s a) -> a +that I have finally given in and written a special type-checking +rule just for saturated appliations of ($). + * Infer the type of the first argument + * Decompose it; should be of form (arg2_ty -> res_ty), + where arg2_ty might be a polytype + * Use arg2_ty to typecheck arg2 + +Note [Typing rule for seq] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to allow + x `seq` (# p,q #) +which suggests this type for seq: + seq :: forall (a:*) (b:??). a -> b -> b, +with (b:??) meaning that be can be instantiated with an unboxed tuple. +But that's ill-kinded! Function arguments can't be unboxed tuples. +And indeed, you could not expect to do this with a partially-applied +'seq'; it's only going to work when it's fully applied. so it turns +into + case x of _ -> (# p,q #) + +For a while I slid by by giving 'seq' an ill-kinded type, but then +the simplifier eta-reduced an application of seq and Lint blew up +with a kind error. It seems more uniform to treat 'seq' as it it +was a language construct. + +See Note [seqId magic] in MkId, and + + \begin{code} -tcExpr in_expr@(OpApp arg1 lop@(L loc op) fix arg2) res_ty - = do { (op', [arg1', arg2']) <- tcApp op 2 (tcArgs lop [arg1,arg2]) res_ty - ; return (OpApp arg1' (L loc op') fix arg2') } - --- Left sections, equivalent to --- \ x -> e op x, --- or --- \ x -> op e x, --- or just --- op e --- --- We treat it as similar to the latter, so we don't --- actually require the function to take two arguments --- at all. For example, (x `not`) means (not x); --- you get postfix operators! Not really Haskell 98 --- I suppose, but it's less work and kind of useful. - -tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty - = do { (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty - ; return (SectionL arg1' (L loc op')) } +tcExpr (OpApp arg1 op fix arg2) res_ty + | (L loc (HsVar op_name)) <- op + , op_name `hasKey` seqIdKey -- Note [Typing rule for seq] + = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind + ; let arg2_ty = res_ty + ; arg1' <- tcArg op (arg1, arg1_ty, 1) + ; arg2' <- tcArg op (arg2, arg2_ty, 2) + ; op_id <- tcLookupId op_name + ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty]) (HsVar op_id)) + ; return $ OpApp arg1' op' fix arg2' } + + | (L loc (HsVar op_name)) <- op + , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] + = do { traceTc "Application rule" (ppr op) + ; (arg1', arg1_ty) <- tcInferRho arg1 + ; let doc = ptext (sLit "The first argument of ($) takes") + ; (co_arg1, [arg2_ty], op_res_ty) <- matchExpectedFunTys doc 1 arg1_ty + -- arg2_ty maybe polymorphic; that's the point + ; arg2' <- tcArg op (arg2, arg2_ty, 2) + ; co_res <- unifyType op_res_ty res_ty + ; op_id <- tcLookupId op_name + ; let op' = L loc (HsWrap (mkWpTyApps [arg2_ty, op_res_ty]) (HsVar op_id)) + ; return $ mkHsWrapCo co_res $ + OpApp (mkLHsWrapCo co_arg1 arg1') op' fix arg2' } + + | otherwise + = do { traceTc "Non Application rule" (ppr op) + ; (op', op_ty) <- tcInferFun op + ; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTys op 2 op_ty + ; co_res <- unifyType op_res_ty res_ty + ; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys + ; return $ mkHsWrapCo co_res $ + OpApp arg1' (mkLHsWrapCo co_fn op') fix arg2' } -- Right sections, equivalent to \ x -> x `op` expr, or -- \ x -> op x expr -tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty - = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty $ \ [arg1_ty'] res_ty' -> - tcApp op 2 (tc_args arg1_ty') res_ty' - ; return (mkHsCoerce co_fn (SectionR (L loc op') arg2')) } +tcExpr (SectionR op arg2) res_ty + = do { (op', op_ty) <- tcInferFun op + ; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTys op 2 op_ty + ; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty + ; arg2' <- tcArg op (arg2, arg2_ty, 2) + ; return $ mkHsWrapCo co_res $ + SectionR (mkLHsWrapCo co_fn op') arg2' } + +tcExpr (SectionL arg1 op) res_ty + = do { (op', op_ty) <- tcInferFun op + ; dflags <- getDOpts -- Note [Left sections] + ; let n_reqd_args | xopt Opt_PostfixOperators dflags = 1 + | otherwise = 2 + + ; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTys op n_reqd_args op_ty + ; co_res <- unifyType (mkFunTys arg_tys op_res_ty) res_ty + ; arg1' <- tcArg op (arg1, arg1_ty, 1) + ; return $ mkHsWrapCo co_res $ + SectionL arg1' (mkLHsWrapCo co_fn op') } + +tcExpr (ExplicitTuple tup_args boxity) res_ty + | all tupArgPresent tup_args + = do { let tup_tc = tupleTyCon boxity (length tup_args) + ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty + ; tup_args1 <- tcTupArgs tup_args arg_tys + ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } + + | otherwise + = -- The tup_args are a mixture of Present and Missing (for tuple sections) + do { let kind = case boxity of { Boxed -> liftedTypeKind + ; Unboxed -> argTypeKind } + arity = length tup_args + tup_tc = tupleTyCon boxity arity + + ; arg_tys <- newFlexiTyVarTys (tyConArity tup_tc) kind + ; let actual_res_ty + = mkFunTys [ty | (ty, Missing _) <- arg_tys `zip` tup_args] + (mkTyConApp tup_tc arg_tys) + + ; coi <- unifyType actual_res_ty res_ty + + -- Handle tuple sections where + ; tup_args1 <- tcTupArgs tup_args arg_tys + + ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } + +tcExpr (ExplicitList _ exprs) res_ty + = do { (coi, elt_ty) <- matchExpectedListTy res_ty + ; exprs' <- mapM (tc_elt elt_ty) exprs + ; return $ mkHsWrapCo coi (ExplicitList elt_ty exprs') } where - doc = ptext SLIT("The section") <+> quotes (ppr in_expr) - <+> ptext SLIT("takes one argument") - tc_args arg1_ty' [arg1_ty, arg2_ty] - = do { boxyUnify arg1_ty' arg1_ty - ; tcArg lop (arg2, arg2_ty, 2) } - tc_args arg1_ty' other = panic "tcExpr SectionR" + tc_elt elt_ty expr = tcPolyExpr expr elt_ty + +tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty + = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty + ; exprs' <- mapM (tc_elt elt_ty) exprs + ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') } + where + tc_elt elt_ty expr = tcPolyExpr expr elt_ty \end{code} +%************************************************************************ +%* * + Let, case, if, do +%* * +%************************************************************************ + \begin{code} tcExpr (HsLet binds expr) res_ty = do { (binds', expr') <- tcLocalBinds binds $ @@ -282,63 +467,69 @@ tcExpr (HsCase scrut matches) exp_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 - (scrut', scrut_ty) <- addErrCtxt (caseScrutCtxt scrut) - (tcInferRho scrut) + (scrut', scrut_ty) <- tcInferRho scrut - ; traceTc (text "HsCase" <+> ppr scrut_ty) + ; traceTc "HsCase" (ppr scrut_ty) ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty ; return (HsCase scrut' matches') } where match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } -tcExpr (HsIf pred b1 b2) res_ty - = do { pred' <- addErrCtxt (predCtxt pred) $ - tcMonoExpr pred boolTy - ; b1' <- tcMonoExpr b1 res_ty - ; b2' <- tcMonoExpr b2 res_ty - ; return (HsIf pred' b1' b2') } - -tcExpr (HsDo do_or_lc stmts body _) res_ty - = tcDoStmts do_or_lc stmts body res_ty - -tcExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list - = do { elt_ty <- boxySplitListTy res_ty - ; exprs' <- mappM (tc_elt elt_ty) exprs - ; return (ExplicitList elt_ty exprs') } - where - tc_elt elt_ty expr = tcPolyExpr expr elt_ty - -tcExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty - = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty - ; exprs' <- mappM (tc_elt elt_ty) exprs - ; ifM (null exprs) (zapToMonotype elt_ty) - -- If there are no expressions in the comprehension - -- we must still fill in the box - -- (Not needed for [] and () becuase they happen - -- to parse as data constructors.) - ; return (ExplicitPArr elt_ty exprs') } - where - tc_elt elt_ty expr = tcPolyExpr expr elt_ty - -tcExpr (ExplicitTuple exprs boxity) res_ty - = do { arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length exprs)) res_ty - ; exprs' <- tcPolyExprs exprs arg_tys - ; return (ExplicitTuple exprs' boxity) } +tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if' + = do { pred' <- tcMonoExpr pred boolTy + ; b1' <- tcMonoExpr b1 res_ty + ; b2' <- tcMonoExpr b2 res_ty + ; return (HsIf Nothing pred' b1' b2') } + +tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Note [Rebindable syntax for if] + = do { pred_ty <- newFlexiTyVarTy openTypeKind + ; b1_ty <- newFlexiTyVarTy openTypeKind + ; b2_ty <- newFlexiTyVarTy openTypeKind + ; let if_ty = mkFunTys [pred_ty, b1_ty, b2_ty] res_ty + ; fun' <- tcSyntaxOp IfOrigin fun if_ty + ; pred' <- tcMonoExpr pred pred_ty + ; b1' <- tcMonoExpr b1 b1_ty + ; b2' <- tcMonoExpr b2 b2_ty + -- Fundamentally we are just typing (ifThenElse e1 e2 e3) + -- so maybe we should use the code for function applications + -- (which would allow ifThenElse to be higher rank). + -- But it's a little awkward, so I'm leaving it alone for now + -- and it maintains uniformity with other rebindable syntax + ; return (HsIf (Just fun') pred' b1' b2') } + +tcExpr (HsDo do_or_lc stmts _) res_ty + = tcDoStmts do_or_lc stmts res_ty tcExpr (HsProc pat cmd) res_ty - = do { (pat', cmd') <- tcProc pat cmd res_ty - ; return (HsProc pat' cmd') } + = do { (pat', cmd', coi) <- tcProc pat cmd res_ty + ; return $ mkHsWrapCo coi (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")]) + = 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")]) + = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e), + ptext (sLit "was found where an expression was expected")]) \end{code} +Note [Rebindable syntax for if] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The rebindable syntax for 'if' uses the most flexible possible type +for conditionals: + ifThenElse :: p -> b1 -> b2 -> res +to support expressions like this: + + ifThenElse :: Maybe a -> (a -> b) -> b -> b + ifThenElse (Just a) f _ = f a ifThenElse Nothing _ e = e + + example :: String + example = if Just 2 + then \v -> show v + else "No value" + + %************************************************************************ %* * Record construction and update @@ -346,160 +537,241 @@ tcExpr e@(HsArrForm _ _ _) _ %************************************************************************ \begin{code} -tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty +tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty = do { data_con <- tcLookupDataCon con_name -- Check for missing fields ; checkMissingFields data_con rbinds + ; (con_expr, con_tau) <- tcInferId con_name ; let arity = dataConSourceArity data_con - check_fields arg_tys - = do { rbinds' <- tcRecordBinds data_con arg_tys rbinds - ; mapM unBox arg_tys - ; return rbinds' } - -- The unBox ensures that all the boxes in arg_tys are indeed - -- filled, which is the invariant expected by tcIdApp - - ; (con_expr, rbinds') <- tcIdApp con_name arity check_fields res_ty - - ; 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: --- --- data T a b = MkT1 { fa :: a, fb :: b } --- | MkT2 { fa :: a, fc :: Int -> Int } --- | MkT3 { fd :: a } --- --- upd :: T a b -> c -> T a c --- upd t x = t { fb = x} --- --- The type signature on upd is correct (i.e. the result should not be (T a b)) --- because upd should be equivalent to: --- --- upd t x = case t of --- MkT1 p q -> MkT1 p x --- MkT2 a b -> MkT2 p b --- MkT3 d -> error ... --- --- So we need to give a completely fresh type to the result record, --- and then constrain it by the fields that are *not* updated ("p" above). --- --- Note that because MkT3 doesn't contain all the fields being updated, --- its RHS is simply an error, so it doesn't impose any type constraints --- --- All this is done in STEP 4 below. --- --- Note about GADTs --- ~~~~~~~~~~~~~~~~ --- For record update we require that every constructor involved in the --- update (i.e. that has all the specified fields) is "vanilla". I --- don't know how to do the update otherwise. - - -tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty - = -- STEP 0 + (arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity + con_id = dataConWrapId data_con + + ; co_res <- unifyType actual_res_ty res_ty + ; rbinds' <- tcRecordBinds data_con arg_tys rbinds + ; return $ mkHsWrapCo co_res $ + RecordCon (L loc con_id) con_expr rbinds' } +\end{code} + +Note [Type of a record update] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The main complication with RecordUpd is that we need to explicitly +handle the *non-updated* fields. Consider: + + data T a b c = MkT1 { fa :: a, fb :: (b,c) } + | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c } + | MkT3 { fd :: a } + + upd :: T a b c -> (b',c) -> T a b' c + upd t x = t { fb = x} + +The result type should be (T a b' c) +not (T a b c), because 'b' *is not* mentioned in a non-updated field +not (T a b' c'), becuase 'c' *is* mentioned in a non-updated field +NB that it's not good enough to look at just one constructor; we must +look at them all; cf Trac #3219 + +After all, upd should be equivalent to: + upd t x = case t of + MkT1 p q -> MkT1 p x + MkT2 a b -> MkT2 p b + MkT3 d -> error ... + +So we need to give a completely fresh type to the result record, +and then constrain it by the fields that are *not* updated ("p" above). +We call these the "fixed" type variables, and compute them in getFixedTyVars. + +Note that because MkT3 doesn't contain all the fields being updated, +its RHS is simply an error, so it doesn't impose any type constraints. +Hence the use of 'relevant_cont'. + +Note [Implict type sharing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We also take into account any "implicit" non-update fields. For example + data T a b where { MkT { f::a } :: T a a; ... } +So the "real" type of MkT is: forall ab. (a~b) => a -> T a b + +Then consider + upd t x = t { f=x } +We infer the type + upd :: T a b -> a -> T a b + upd (t::T a b) (x::a) + = case t of { MkT (co:a~b) (_:a) -> MkT co x } +We can't give it the more general type + upd :: T a b -> c -> T c b + +Note [Criteria for update] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to allow update for existentials etc, provided the updated +field isn't part of the existential. For example, this should be ok. + data T a where { MkT { f1::a, f2::b->b } :: T a } + f :: T a -> b -> T b + f t b = t { f1=b } + +The criterion we use is this: + + The types of the updated fields + mention only the universally-quantified type variables + of the data constructor + +NB: this is not (quite) the same as being a "naughty" record selector +(See Note [Naughty record selectors]) in TcTyClsDecls), at least +in the case of GADTs. Consider + data T a where { MkT :: { f :: a } :: T [a] } +Then f is not "naughty" because it has a well-typed record selector. +But we don't allow updates for 'f'. (One could consider trying to +allow this, but it makes my head hurt. Badly. And no one has asked +for it.) + +In principle one could go further, and allow + g :: T a -> T a + g t = t { f2 = \x -> x } +because the expression is polymorphic...but that seems a bridge too far. + +Note [Data family example] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + data instance T (a,b) = MkT { x::a, y::b } + ---> + data :TP a b = MkT { a::a, y::b } + coTP a b :: T (a,b) ~ :TP a b + +Suppose r :: T (t1,t2), e :: t3 +Then r { x=e } :: T (t3,t1) + ---> + case r |> co1 of + MkT x y -> MkT e y |> co2 + where co1 :: T (t1,t2) ~ :TP t1 t2 + co2 :: :TP t3 t2 ~ T (t3,t2) +The wrapping with co2 is done by the constructor wrapper for MkT + +Outgoing invariants +~~~~~~~~~~~~~~~~~~~ +In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys): + + * cons are the data constructors to be updated + + * in_inst_tys, out_inst_tys have same length, and instantiate the + *representation* tycon of the data cons. In Note [Data + family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2] + +\begin{code} +tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty + = ASSERT( notNull upd_fld_names ) + do { + -- STEP 0 -- Check that the field names are really field names - ASSERT( notNull rbinds ) - let - field_names = map fst rbinds - in - mappM (tcLookupField . unLoc) field_names `thenM` \ sel_ids -> - -- The renamer has already checked that they - -- are all in scope - let - 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_` + ; sel_ids <- mapM tcLookupField upd_fld_names + -- The renamer has already checked that + -- selectors are all in scope + ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name) + | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids, + not (isRecordSelector sel_id), -- Excludes class ops + let L loc fld_name = hsRecFieldId fld ] + ; unless (null bad_guys) (sequence bad_guys >> failM) -- STEP 1 -- 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) - upd_field_lbls = recBindFields rbinds - sel_id : _ = sel_ids - (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if - data_cons = tyConDataCons tycon -- it's not a field label - relevant_cons = filter is_relevant data_cons - is_relevant con = all (`elem` dataConFieldLabels con) upd_field_lbls - in - - -- 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 (not (null relevant_cons)) - (badFieldsUpd rbinds) `thenM_` - - -- Check that all relevant data cons are vanilla. Doing record updates on - -- GADTs and/or existentials is more than my tiny brain can cope with today - checkTc (all isVanillaDataCon relevant_cons) - (nonVanillaUpd tycon) `thenM_` - - -- STEP 4 - -- Use the un-updated fields to find a vector of booleans saying - -- which type arguments must be the same in updatee and result. - -- - -- WARNING: this code assumes that all data_cons in a common tycon - -- have FieldLabels abstracted over the same tyvars. - let + ; let -- It's OK to use the non-tc splitters here (for a selector) + sel_id : _ = sel_ids + (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if + data_cons = tyConDataCons tycon -- it's not a field label + -- NB: for a data type family, the tycon is the instance tycon + + relevant_cons = filter is_relevant data_cons + is_relevant con = all (`elem` dataConFieldLabels con) upd_fld_names -- A constructor is only relevant to this process if -- it contains *all* the fields that are being updated - con1 = head relevant_cons -- A representative constructor - con1_tyvars = dataConUnivTyVars con1 - con1_flds = dataConFieldLabels con1 - con1_arg_tys = dataConOrigArgTys con1 - common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_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 = newFlexiTyVarTy (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 -> - - -- 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 - con1_arg_tys' = map (substTy inst_env) con1_arg_tys - in - tcSubExp result_record_ty res_ty `thenM` \ co_fn -> - tcRecordBinds con1 con1_arg_tys' rbinds `thenM` \ rbinds' -> + -- Other ones will cause a runtime error if they occur + + -- Take apart a representative constructor + con1 = ASSERT( not (null relevant_cons) ) head relevant_cons + (con1_tvs, _, _, _, con1_arg_tys, _) = dataConFullSig con1 + con1_flds = dataConFieldLabels con1 + con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs) + + -- 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 (not (null relevant_cons)) (badFieldsUpd rbinds) + + -- STEP 3 Note [Criteria for update] + -- Check that each updated field is polymorphic; that is, its type + -- mentions only the universally-quantified variables of the data con + ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys + upd_flds1_w_tys = filter is_updated flds1_w_tys + is_updated (fld,_) = fld `elem` upd_fld_names + + bad_upd_flds = filter bad_fld upd_flds1_w_tys + con1_tv_set = mkVarSet con1_tvs + bad_fld (fld, ty) = fld `elem` upd_fld_names && + not (tyVarsOfType ty `subVarSet` con1_tv_set) + ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds) + + -- STEP 4 Note [Type of a record update] + -- Figure out types for the scrutinee and result + -- Both are of form (T a b c), with fresh type variables, but with + -- common variables where the scrutinee and result must have the same type + -- These are variables that appear in *any* arg of *any* of the + -- relevant constructors *except* in the updated fields + -- + ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons + is_fixed_tv tv = tv `elemVarSet` fixed_tvs + mk_inst_ty tv result_inst_ty + | is_fixed_tv tv = return result_inst_ty -- Same as result type + | otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind + + ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs + ; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys + + ; let rec_res_ty = TcType.substTy result_inst_env con1_res_ty + con1_arg_tys' = map (TcType.substTy result_inst_env) con1_arg_tys + scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys + scrut_ty = TcType.substTy scrut_subst con1_res_ty + + ; co_res <- unifyType rec_res_ty res_ty -- STEP 5 - -- Typecheck the expression to be updated - let - 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 - tcMonoExpr record_expr record_ty `thenM` \ record_expr' -> - - -- STEP 6 - -- Figure out the LIE we need. We have to generate some - -- dictionaries for the data type context, since we are going to - -- do pattern matching over the data cons. - -- - -- What dictionaries do we need? The tyConStupidTheta tells us. - let - theta' = substTheta inst_env (tyConStupidTheta tycon) - in - instStupidTheta RecordUpdOrigin theta' `thenM_` - + -- Typecheck the thing to be updated, and the bindings + ; record_expr' <- tcMonoExpr record_expr scrut_ty + ; rbinds' <- tcRecordBinds con1 con1_arg_tys' rbinds + + -- STEP 6: Deal with the stupid theta + ; let theta' = substTheta scrut_subst (dataConStupidTheta con1) + ; instStupidTheta RecordUpdOrigin theta' + + -- Step 7: make a cast for the scrutinee, in the case that it's from a type family + ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon + = WpCast $ mkAxInstCo co_con scrut_inst_tys + | otherwise + = idHsWrapper -- Phew! - returnM (mkHsCoerce co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty)) + ; return $ mkHsWrapCo co_res $ + RecordUpd (mkLHsWrap scrut_co record_expr') rbinds' + relevant_cons scrut_inst_tys result_inst_tys } + where + upd_fld_names = hsRecFields rbinds + + getFixedTyVars :: [TyVar] -> [DataCon] -> TyVarSet + -- These tyvars must not change across the updates + getFixedTyVars tvs1 cons + = mkVarSet [tv1 | con <- cons + , let (tvs, theta, arg_tys, _) = dataConSig con + flds = dataConFieldLabels con + fixed_tvs = exactTyVarsOfTypes fixed_tys + -- fixed_tys: See Note [Type of a record update] + `unionVarSet` tyVarsOfTheta theta + -- Universally-quantified tyvars that + -- appear in any of the *implicit* + -- arguments to the constructor are fixed + -- See Note [Implict type sharing] + + fixed_tys = [ty | (fld,ty) <- zip flds arg_tys + , not (fld `elem` upd_fld_names)] + , (tv1,tv) <- tvs1 `zip` tvs -- Discards existentials in tvs + , tv `elemVarSet` fixed_tvs ] \end{code} - %************************************************************************ %* * Arithmetic sequences e.g. [a,b..] @@ -510,54 +782,58 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty \begin{code} tcExpr (ArithSeq _ seq@(From expr)) res_ty - = do { elt_ty <- boxySplitListTy res_ty + = do { (coi, elt_ty) <- matchExpectedListTy res_ty ; expr' <- tcPolyExpr expr elt_ty ; enum_from <- newMethodFromName (ArithSeqOrigin seq) - elt_ty enumFromName - ; return (ArithSeq (HsVar enum_from) (From expr')) } + enumFromName elt_ty + ; return $ mkHsWrapCo coi (ArithSeq enum_from (From expr')) } -tcExpr in_expr@(ArithSeq _ seq@(FromThen expr1 expr2)) res_ty - = do { elt_ty <- boxySplitListTy res_ty +tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty + = do { (coi, elt_ty) <- matchExpectedListTy res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) - elt_ty enumFromThenName - ; return (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) } - + enumFromThenName elt_ty + ; return $ mkHsWrapCo coi + (ArithSeq enum_from_then (FromThen expr1' expr2')) } -tcExpr in_expr@(ArithSeq _ seq@(FromTo expr1 expr2)) res_ty - = do { elt_ty <- boxySplitListTy res_ty +tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty + = do { (coi, elt_ty) <- matchExpectedListTy res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) - elt_ty enumFromToName - ; return (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) } + enumFromToName elt_ty + ; return $ mkHsWrapCo coi + (ArithSeq enum_from_to (FromTo expr1' expr2')) } -tcExpr in_expr@(ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty - = do { elt_ty <- boxySplitListTy res_ty +tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty + = do { (coi, elt_ty) <- matchExpectedListTy res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; expr3' <- tcPolyExpr expr3 elt_ty ; eft <- newMethodFromName (ArithSeqOrigin seq) - elt_ty enumFromThenToName - ; return (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) } + enumFromThenToName elt_ty + ; return $ mkHsWrapCo coi + (ArithSeq eft (FromThenTo expr1' expr2' expr3')) } -tcExpr in_expr@(PArrSeq _ seq@(FromTo expr1 expr2)) res_ty - = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty +tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty + = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq) - elt_ty enumFromToPName - ; return (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) } + (enumFromToPName basePackageId) elt_ty -- !!!FIXME: chak + ; return $ mkHsWrapCo coi + (PArrSeq enum_from_to (FromTo expr1' expr2')) } -tcExpr in_expr@(PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty - = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty +tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty + = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; expr3' <- tcPolyExpr expr3 elt_ty ; eft <- newMethodFromName (PArrSeqOrigin seq) - elt_ty enumFromThenToPName - ; return (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) } + (enumFromThenToPName basePackageId) elt_ty -- !!!FIXME: chak + ; return $ mkHsWrapCo coi + (PArrSeq eft (FromThenTo expr1' expr2' expr3')) } tcExpr (PArrSeq _ _) _ = panic "TcExpr.tcMonoExpr: Infinite parallel array!" @@ -578,6 +854,8 @@ tcExpr (PArrSeq _ _) _ tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty tcExpr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty ; return (unLoc e) } +tcExpr e@(HsQuasiQuoteE _) _ = + pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e) #endif /* GHCI */ \end{code} @@ -600,224 +878,240 @@ tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) %************************************************************************ \begin{code} ---------------------------- -tcApp :: HsExpr Name -- Function - -> Arity -- Number of args reqd - -> ([BoxySigmaType] -> TcM arg_results) -- Argument type-checker - -> BoxyRhoType -- Result type - -> TcM (HsExpr TcId, arg_results) +tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args + -> TcRhoType -> TcM (HsExpr TcId) -- Translated fun and args + +tcApp (L _ (HsPar e)) args res_ty + = tcApp e args res_ty + +tcApp (L _ (HsApp e1 e2)) args res_ty + = tcApp e1 (e2:args) res_ty -- Accumulate the arguments + +tcApp (L loc (HsVar fun)) args res_ty + | fun `hasKey` tagToEnumKey + , [arg] <- args + = tcTagToEnum loc fun arg res_ty + +tcApp fun args res_ty + = do { -- Type-check the function + ; (fun1, fun_tau) <- tcInferFun fun + + -- Extract its argument types + ; (co_fun, expected_arg_tys, actual_res_ty) + <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau + + -- Typecheck the result, thereby propagating + -- info (if any) from result into the argument types + -- Both actual_res_ty and res_ty are deeply skolemised + ; co_res <- addErrCtxtM (funResCtxt fun actual_res_ty res_ty) $ + unifyType actual_res_ty res_ty + + -- Typecheck the arguments + ; args1 <- tcArgs fun args expected_arg_tys + + -- Assemble the result + ; let fun2 = mkLHsWrapCo co_fun fun1 + app = mkLHsWrapCo co_res (foldl mkHsApp fun2 args1) + + ; return (unLoc app) } + + +mk_app_msg :: LHsExpr Name -> SDoc +mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun) + , ptext (sLit "is applied to")] + +---------------- +tcInferApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args + -> TcM (HsExpr TcId, TcRhoType) -- Translated fun and args + +tcInferApp (L _ (HsPar e)) args = tcInferApp e args +tcInferApp (L _ (HsApp e1 e2)) args = tcInferApp e1 (e2:args) +tcInferApp fun args + = -- Very like the tcApp version, except that there is + -- no expected result type passed in + do { (fun1, fun_tau) <- tcInferFun fun + ; (co_fun, expected_arg_tys, actual_res_ty) + <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau + ; args1 <- tcArgs fun args expected_arg_tys + ; let fun2 = mkLHsWrapCo co_fun fun1 + app = foldl mkHsApp fun2 args1 + ; return (unLoc app, actual_res_ty) } + +---------------- +tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) +-- Infer and instantiate the type of a function +tcInferFun (L loc (HsVar name)) + = do { (fun, ty) <- setSrcSpan loc (tcInferId name) + -- Don't wrap a context around a plain Id + ; return (L loc fun, ty) } + +tcInferFun fun + = do { (fun, fun_ty) <- tcInfer (tcMonoExpr fun) + + -- Zonk the function type carefully, to expose any polymorphism + -- E.g. (( \(x::forall a. a->a). blah ) e) + -- We can see the rank-2 type of the lambda in time to genrealise e + ; fun_ty' <- zonkTcTypeCarefully fun_ty + + ; (wrap, rho) <- deeplyInstantiate AppOrigin fun_ty' + ; return (mkLHsWrap wrap fun, rho) } + +---------------- +tcArgs :: LHsExpr Name -- The function (for error messages) + -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types + -> TcM [LHsExpr TcId] -- Resulting args --- (tcFun fun n_args arg_checker res_ty) --- The argument type checker, arg_checker, will be passed exactly n_args types +tcArgs fun args expected_arg_tys + = mapM (tcArg fun) (zip3 args expected_arg_tys [1..]) -tcApp (HsVar fun_name) n_args arg_checker res_ty - = tcIdApp fun_name n_args arg_checker res_ty +---------------- +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) + (tcPolyExprNC arg ty) -tcApp fun n_args arg_checker res_ty -- The vanilla case (rula APP) - = do { arg_boxes <- newBoxyTyVars (replicate n_args argTypeKind) - ; fun' <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty) - ; arg_tys' <- mapM readFilledBox arg_boxes - ; args' <- arg_checker arg_tys' - ; return (fun', args') } +---------------- +tcTupArgs :: [HsTupArg Name] -> [TcSigmaType] -> TcM [HsTupArg TcId] +tcTupArgs args tys + = ASSERT( equalLength args tys ) mapM go (args `zip` tys) + where + go (Missing {}, arg_ty) = return (Missing arg_ty) + go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty + ; return (Present expr') } + +---------------- +unifyOpFunTys :: LHsExpr Name -> Arity -> TcRhoType + -> TcM (Coercion, [TcSigmaType], TcRhoType) +-- A wrapper for matchExpectedFunTys +unifyOpFunTys op arity ty = matchExpectedFunTys herald arity ty + where + herald = ptext (sLit "The operator") <+> quotes (ppr op) <+> ptext (sLit "takes") --------------------------- -tcIdApp :: Name -- Function - -> Arity -- Number of args reqd - -> ([BoxySigmaType] -> TcM arg_results) -- Argument type-checker - -- The arg-checker guarantees to fill all boxes in the arg types - -> BoxyRhoType -- Result type - -> TcM (HsExpr TcId, arg_results) - --- Call (f e1 ... en) :: res_ty --- Type f :: forall a b c. theta => fa_1 -> ... -> fa_k -> fres --- (where k <= n; fres has the rest) --- NB: if k < n then the function doesn't have enough args, and --- presumably fres is a type variable that we are going to --- instantiate with a function type --- --- Then fres <= bx_(k+1) -> ... -> bx_n -> res_ty - -tcIdApp fun_name n_args arg_checker res_ty - = do { let orig = OccurrenceOf fun_name - ; (fun, fun_ty) <- lookupFun orig fun_name - - -- Split up the function type - ; let (tv_theta_prs, rho) = tcMultiSplitSigmaTy fun_ty - (fun_arg_tys, fun_res_ty) = tcSplitFunTysN rho n_args - - qtvs = concatMap fst tv_theta_prs -- Quantified tyvars - arg_qtvs = exactTyVarsOfTypes fun_arg_tys - res_qtvs = exactTyVarsOfType fun_res_ty - -- NB: exactTyVarsOfType. See Note [Silly type synonyms in smart-app] - tau_qtvs = arg_qtvs `unionVarSet` res_qtvs - k = length fun_arg_tys -- k <= n_args - n_missing_args = n_args - k -- Always >= 0 - - -- Match the result type of the function with the - -- result type of the context, to get an inital substitution - ; extra_arg_boxes <- newBoxyTyVars (replicate n_missing_args argTypeKind) - ; let extra_arg_tys' = mkTyVarTys extra_arg_boxes - res_ty' = mkFunTys extra_arg_tys' res_ty - ; qtys' <- preSubType qtvs tau_qtvs fun_res_ty res_ty' - ; let arg_subst = zipOpenTvSubst qtvs qtys' - fun_arg_tys' = substTys arg_subst fun_arg_tys - - -- Typecheck the arguments! - -- Doing so will fill arg_qtvs and extra_arg_tys' - ; args' <- arg_checker (fun_arg_tys' ++ extra_arg_tys') - - -- Strip boxes from the qtvs that have been filled in by the arg checking - -- AND any variables that are mentioned in neither arg nor result - -- the latter are mentioned only in constraints; stripBoxyType will - -- fill them with a monotype - ; let strip qtv qty' | qtv `elemVarSet` arg_qtvs = stripBoxyType qty' - | otherwise = return qty' - ; qtys'' <- zipWithM strip qtvs qtys' - ; extra_arg_tys'' <- mapM readFilledBox extra_arg_boxes - - -- Result subsumption - ; let res_subst = zipOpenTvSubst qtvs qtys'' - fun_res_ty'' = substTy res_subst fun_res_ty - res_ty'' = mkFunTys extra_arg_tys'' res_ty - ; co_fn <- tcFunResTy fun_name fun_res_ty'' res_ty'' - - -- And pack up the results - -- By applying the coercion just to the *function* we can make - -- tcFun work nicely for OpApp and Sections too - ; fun' <- instFun orig fun res_subst tv_theta_prs - ; co_fn' <- wrapFunResCoercion fun_arg_tys' co_fn - ; return (mkHsCoerce co_fn' fun', args') } +tcSyntaxOp :: CtOrigin -> 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) +-- This version assumes res_ty is a monotype +tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig op + ; tcWrapResult expr rho res_ty } +tcSyntaxOp _ other _ = pprPanic "tcSyntaxOp" (ppr other) \end{code} -Note [Silly type synonyms in smart-app] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we call sripBoxyType, all of the boxes should be filled -in. But we need to be careful about type synonyms: - type T a = Int - f :: T a -> Int - ...(f x)... -In the call (f x) we'll typecheck x, expecting it to have type -(T box). Usually that would fill in the box, but in this case not; -because 'a' is discarded by the silly type synonym T. So we must -use exactTyVarsOfType to figure out which type variables are free -in the argument type. -\begin{code} --- tcId is a specialisation of tcIdApp when there are no arguments --- tcId f ty = do { (res, _) <- tcIdApp f [] (\[] -> return ()) ty --- ; return res } - -tcId :: InstOrigin - -> Name -- Function - -> BoxyRhoType -- Result type - -> TcM (HsExpr TcId) -tcId orig fun_name res_ty - = do { traceTc (text "tcId" <+> ppr fun_name <+> ppr res_ty) - ; (fun, fun_ty) <- lookupFun orig fun_name - - -- Split up the function type - ; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy fun_ty - qtvs = concatMap fst tv_theta_prs -- Quantified tyvars - tau_qtvs = exactTyVarsOfType fun_tau -- Mentioned in the tau part - ; qtv_tys <- preSubType qtvs tau_qtvs fun_tau res_ty - - -- Do the subsumption check wrt the result type - ; let res_subst = zipTopTvSubst qtvs qtv_tys - fun_tau' = substTy res_subst fun_tau - - ; co_fn <- tcFunResTy fun_name fun_tau' res_ty - - -- And pack up the results - ; fun' <- instFun orig fun res_subst tv_theta_prs - ; return (mkHsCoerce co_fn fun') } - --- 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.] +Note [Push result type in] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unify with expected result before type-checking the args so that the +info from res_ty percolates to args. 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.) +experimenting with putting this first. ---------------------------- -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 = tcId orig op ty -tcSyntaxOp orig other ty = pprPanic "tcSyntaxOp" (ppr other) +Here's an example where it actually makes a real difference ---------------------------- -instFun :: InstOrigin - -> HsExpr TcId - -> TvSubst -- The instantiating substitution - -> [([TyVar], ThetaType)] -- Stuff to instantiate - -> TcM (HsExpr TcId) + 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) -instFun orig fun subst [] - = return fun -- Common short cut +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. -instFun orig fun subst tv_theta_prs - = do {-- !!!SPJ: -- Horrid check for tagToEnum; see Note [tagToEnum#] - -- !!!SPJ: checkBadTagToEnumCall fun_id qtv_tys - ; let ty_theta_prs' = map subst_pr tv_theta_prs +%************************************************************************ +%* * + tcInferId +%* * +%************************************************************************ + +\begin{code} +tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId) +tcCheckId name res_ty = do { (expr, rho) <- tcInferId name + ; tcWrapResult expr rho res_ty } + +------------------------ +tcInferId :: Name -> TcM (HsExpr TcId, TcRhoType) +-- Infer type, and deeply instantiate +tcInferId n = tcInferIdWithOrig (OccurrenceOf n) n + +------------------------ +tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType) +-- Look up an occurrence of an Id, and instantiate it (deeply) + +tcInferIdWithOrig orig id_name = + do { id_level <- getIdLevel id_name + ; cur_level <- getHetMetLevel + ; if (length id_level < length cur_level) + then do { (lhexp, tcrho) <- + tcInferRho (noLoc $ addEscapes (take ((length cur_level) - (length id_level)) cur_level) (HsVar id_name)) + ; return (unLoc lhexp, tcrho) + } + else tcInferIdWithOrig' orig id_name + } - -- First, chuck in the constraints from - -- the "stupid theta" of a data constructor (sigh) - ; inst_stupid fun ty_theta_prs' +tcInferIdWithOrig' orig id_name = + do { id <- lookup_id + ; (id_expr, id_rho) <- instantiateOuter orig id + ; (wrap, rho) <- deeplyInstantiate orig id_rho + ; return (mkHsWrap wrap id_expr, rho) } + where + lookup_id :: TcM TcId + lookup_id + = do { thing <- tcLookup id_name + ; case thing of + ATcId { tct_id = id, tct_level = lvl, tct_hetMetLevel = variable_hetMetLevel } + -> do { check_naughty id -- Note [Local record selectors] + ; checkThLocalId id lvl + ; current_hetMetLevel <- getHetMetLevel + ; mapM + (\(name1,name2) -> unifyType (TyVarTy name1) (TyVarTy name2)) + (zip variable_hetMetLevel current_hetMetLevel) + ; return id } + + AGlobal (AnId id) + -> do { check_naughty id + ; return id } + -- A global cannot possibly be ill-staged in Template Haskell + -- nor does it need the 'lifting' treatment + -- hence no checkTh stuff here + + AGlobal (ADataCon con) -> return (dataConWrapId con) + + other -> failWithTc (bad_lookup other) } + + bad_lookup thing = ppr thing <+> ptext (sLit "used where a value identifer was expected") + + check_naughty id + | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id) + | otherwise = return () + +------------------------ +instantiateOuter :: CtOrigin -> TcId -> TcM (HsExpr TcId, TcSigmaType) +-- Do just the first level of instantiation of an Id +-- a) Deal with method sharing +-- b) Deal with stupid checks +-- Only look at the *outer level* of quantification +-- See Note [Multiple instantiation] + +instantiateOuter orig id + | null tvs && null theta + = return (HsVar id, tau) - -- Now do normal instantiation - ; go True fun ty_theta_prs' } + | otherwise + = do { (_, tys, subst) <- tcInstTyVars tvs + ; doStupidChecks id tys + ; let theta' = substTheta subst theta + ; traceTc "Instantiating" (ppr id <+> text "with" <+> (ppr tys $$ ppr theta')) + ; wrap <- instCall orig tys theta' + ; return (mkHsWrap wrap (HsVar id), TcType.substTy subst tau) } where - subst_pr (tvs, theta) - = (map (substTyVar subst) tvs, substTheta subst theta) - - inst_stupid (HsVar fun_id) ((tys,_):_) - | Just con <- isDataConId_maybe fun_id - = addDataConStupidTheta orig con tys - inst_stupid _ _ = return () - - go _ fun [] = return fun - - go True (HsVar fun_id) ((tys,theta) : prs) - | want_method_inst theta - = do { meth_id <- newMethodWithGivenTy orig fun_id tys - ; go False (HsVar meth_id) prs } - -- Go round with 'False' to prevent further use - -- of newMethod: see Note [Multiple instantiation] - - go _ fun ((tys, theta) : prs) - = do { co_fn <- instCall orig tys theta - ; go False (HsCoerce co_fn fun) prs } - - -- Hack Alert (want_method_inst)! - -- See Note [No method sharing] - -- 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: - -- let m = f %x in (m 3, m 4) - -- 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 theta = not (null theta) -- Overloaded - && not (any isLinearPred theta) -- Not linear - && not opt_NoMethodSharing - -- See Note [No method sharing] below + (tvs, theta, tau) = tcSplitSigmaTy (idType id) \end{code} Note [Multiple instantiation] @@ -870,26 +1164,33 @@ This gets a bit less sharing, but b) perhaps fewer separated lambdas \begin{code} -tcArgs :: LHsExpr Name -- The function (for error messages) - -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types - -> TcM [LHsExpr TcId] -- Resulting args - -tcArgs fun args expected_arg_tys - = mapM (tcArg fun) (zip3 args expected_arg_tys [1..]) - -tcArg :: LHsExpr Name -- The function (for error messages) - -> (LHsExpr Name, BoxySigmaType, Int) -- Actual argument and expected arg type - -> TcM (LHsExpr TcId) -- Resulting argument -tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) $ - tcPolyExprNC arg ty +doStupidChecks :: TcId + -> [TcType] + -> TcM () +-- Check two tiresome and ad-hoc cases +-- (a) the "stupid theta" for a data con; add the constraints +-- from the "stupid theta" of a data constructor (sigh) + +doStupidChecks fun_id tys + | Just con <- isDataConId_maybe fun_id -- (a) + = addDataConStupidTheta con tys + + | fun_id `hasKey` tagToEnumKey -- (b) + = failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument")) + + | otherwise + = return () -- The common case \end{code} - Note [tagToEnum#] ~~~~~~~~~~~~~~~~~ Nasty check to ensure that tagToEnum# is applied to a type that is an enumeration TyCon. Unification may refine the type later, but this -check won't see that, alas. It's crude but it works. +check won't see that, alas. It's crude, because it relies on our +knowing *now* that the type is ok, which in turn relies on the +eager-unification part of the type checker pushing enough information +here. In theory the Right Thing to do is to have a new form of +constraint but I definitely cannot face that! And it works ok as-is. Here's are two cases that should fail f :: forall a. a @@ -898,80 +1199,108 @@ Here's are two cases that should fail g :: Int g = tagToEnum# 0 -- Int is not an enumeration +When data type families are involved it's a bit more complicated. + data family F a + data instance F [Int] = A | B | C +Then we want to generate something like + tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int] +Usually that coercion is hidden inside the wrappers for +constructors of F [Int] but here we have to do it explicitly. + +It's all grotesquely complicated. \begin{code} -checkBadTagToEnumCall :: Id -> [TcType] -> TcM () -checkBadTagToEnumCall fun_id tys - | fun_id `hasKey` tagToEnumKey - = do { tys' <- zonkTcTypes tys - ; checkTc (ok tys') (tagToEnumError tys') - } - | otherwise -- Vastly common case - = return () - where - ok [] = False - ok (ty:tys) = case tcSplitTyConApp_maybe ty of - Just (tc,_) -> isEnumerationTyCon tc - Nothing -> False - -tagToEnumError tys - = hang (ptext SLIT("Bad call to tagToEnum#") <+> at_type) - 2 (vcat [ptext SLIT("Specify the type by giving a type signature"), - ptext SLIT("e.g. (tagToEnum# x) :: Bool")]) +tcTagToEnum :: SrcSpan -> Name -> LHsExpr Name -> TcRhoType -> TcM (HsExpr TcId) +-- tagToEnum# :: forall a. Int# -> a +-- See Note [tagToEnum#] Urgh! +tcTagToEnum loc fun_name arg res_ty + = do { fun <- tcLookupId fun_name + ; ty' <- zonkTcType res_ty + + -- Check that the type is algebraic + ; let mb_tc_app = tcSplitTyConApp_maybe ty' + Just (tc, tc_args) = mb_tc_app + ; checkTc (isJust mb_tc_app) + (tagToEnumError ty' doc1) + + -- Look through any type family + ; (coi, rep_tc, rep_args) <- get_rep_ty ty' tc tc_args + + ; checkTc (isEnumerationTyCon rep_tc) + (tagToEnumError ty' doc2) + + ; arg' <- tcMonoExpr arg intPrimTy + ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun)) + rep_ty = mkTyConApp rep_tc rep_args + + ; return (mkHsWrapCo coi $ HsApp fun' arg') } where - at_type | null tys = empty -- Probably never happens - | otherwise = ptext SLIT("at type") <+> ppr (head tys) + doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature") + , ptext (sLit "e.g. (tagToEnum# x) :: Bool") ] + doc2 = ptext (sLit "Result type must be an enumeration type") + doc3 = ptext (sLit "No family instance for this type") + + get_rep_ty :: TcType -> TyCon -> [TcType] + -> TcM (Coercion, TyCon, [TcType]) + -- Converts a family type (eg F [a]) to its rep type (eg FList a) + -- and returns a coercion between the two + get_rep_ty ty tc tc_args + | not (isFamilyTyCon tc) + = return (mkReflCo ty, tc, tc_args) + | otherwise + = do { mb_fam <- tcLookupFamInst tc tc_args + ; case mb_fam of + Nothing -> failWithTc (tagToEnumError ty doc3) + Just (rep_tc, rep_args) + -> return ( mkSymCo (mkAxInstCo co_tc rep_args) + , rep_tc, rep_args ) + where + co_tc = expectJust "tcTagToEnum" $ + tyConFamilyCoercion_maybe rep_tc } + +tagToEnumError :: TcType -> SDoc -> SDoc +tagToEnumError ty what + = hang (ptext (sLit "Bad call to tagToEnum#") + <+> ptext (sLit "at type") <+> ppr ty) + 2 what \end{code} + %************************************************************************ %* * -\subsection{@tcId@ typchecks an identifier occurrence} + Template Haskell checks %* * %************************************************************************ \begin{code} -lookupFun :: InstOrigin -> Name -> TcM (HsExpr TcId, TcType) -lookupFun orig id_name - = do { thing <- tcLookup id_name - ; case thing of - AGlobal (ADataCon con) -> return (HsVar wrap_id, idType wrap_id) - where - wrap_id = dataConWrapId con - - AGlobal (AnId id) - | isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id) - | otherwise -> return (HsVar id, idType id) - -- A global cannot possibly be ill-staged - -- nor does it need the 'lifting' treatment - - ATcId { tct_id = id, tct_type = ty, tct_co = mb_co, tct_level = lvl } - -> do { thLocalId orig id ty lvl - ; case mb_co of - Nothing -> return (HsVar id, ty) -- Wobbly, or no free vars - Just co -> return (mkHsCoerce co (HsVar id), ty) } - - other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected")) - } - +checkThLocalId :: Id -> ThLevel -> TcM () #ifndef GHCI /* GHCI and TH is off */ -------------------------------------- --- thLocalId : Check for cross-stage lifting -thLocalId orig id id_ty th_bind_lvl +-- Check for cross-stage lifting +checkThLocalId _id _bind_lvl = return () #else /* GHCI and TH is on */ -thLocalId orig id id_ty th_bind_lvl +checkThLocalId id bind_lvl = do { use_stage <- getStage -- TH case - ; case use_stage of - Brack use_lvl ps_var lie_var | use_lvl > th_bind_lvl - -> thBrackId orig id ps_var lie_var - other -> do { checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage - ; return id } - } + ; let use_lvl = thLevel use_stage + ; checkWellStaged (quotes (ppr id)) bind_lvl use_lvl + ; traceTc "thLocalId" (ppr id <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl) + ; when (use_lvl > bind_lvl) $ + checkCrossStageLifting id bind_lvl use_stage } -------------------------------------- -thBrackId orig id ps_var lie_var - | isExternalName id_name +checkCrossStageLifting :: Id -> ThLevel -> ThStage -> TcM () +-- We are inside brackets, and (use_lvl > bind_lvl) +-- Now we must check whether there's a cross-stage lift to do +-- Examples \x -> [| x |] +-- [| map |] + +checkCrossStageLifting _ _ Comp = return () +checkCrossStageLifting _ _ Splice = return () + +checkCrossStageLifting id _ (Brack _ ps_var lie_var) + | thTopLevelId id = -- Top-level identifiers in this module, -- (which have External Names) -- are just like the imported case: @@ -982,9 +1311,10 @@ thBrackId orig id ps_var lie_var -- 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. - do { keepAliveTc id_name; return id } + keepAliveTc id - | otherwise + | otherwise -- bind_lvl = outerLevel presumably, + -- but the Id is not bound at top level = -- Nested identifiers, such as 'x' in -- E.g. \x -> [| h x |] -- We must behave as if the reference to x was @@ -995,33 +1325,49 @@ thBrackId orig id ps_var lie_var -- bindings of the same splice proxy, but that doesn't -- matter, although it's a mite untidy. do { let id_ty = idType id - ; checkTc (isTauTy id_ty) (polySpliceErr id) + ; checkTc (isTauTy id_ty) (polySpliceErr id) -- 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 - ; id_ty' <- zapToMonotype id_ty - -- The id_ty might have an OpenTypeKind, but we - -- can't instantiate the Lift class at that kind, - -- so we zap it to a LiftedTypeKind monotype - -- C.f. the call in TcPat.newLitInst - - ; setLIEVar lie_var $ do - { lift <- newMethodFromName orig id_ty' DsMeta.liftName - -- Put the 'lift' constraint into the right LIE + ; lift <- if isStringTy id_ty then + do { sid <- tcLookupId DsMeta.liftStringName + -- See Note [Lifting strings] + ; return (HsVar sid) } + else + setConstraintVar lie_var $ do + -- Put the 'lift' constraint into the right LIE + newMethodFromName (OccurrenceOf (idName id)) + DsMeta.liftName id_ty -- Update the pending splices ; ps <- readMutVar ps_var - ; writeMutVar ps_var ((id_name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps) + ; writeMutVar ps_var ((idName id, nlHsApp (noLoc lift) (nlHsVar id)) : ps) - ; return id } } - where - id_name = idName id + ; return () } #endif /* GHCI */ \end{code} +Note [Lifting strings] +~~~~~~~~~~~~~~~~~~~~~~ +If we see $(... [| s |] ...) where s::String, we don't want to +generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc. +So this conditional short-circuits the lifting mechanism to generate +(liftString "xy") in that case. I didn't want to use overlapping instances +for the Lift class in TH.Syntax, because that can lead to overlapping-instance +errors in a polymorphic situation. + +If this check fails (which isn't impossible) we get another chance; see +Note [Converting strings] in Convert.lhs + +Local record selectors +~~~~~~~~~~~~~~~~~~~~~~ +Record selectors for TyCons in this module are ordinary local bindings, +which show up as ATcIds rather than AGlobals. So we need to check for +naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds. + %************************************************************************ %* * @@ -1053,18 +1399,23 @@ tcRecordBinds -> HsRecordBinds Name -> TcM (HsRecordBinds TcId) -tcRecordBinds data_con arg_tys rbinds - = do { mb_binds <- mappM do_bind rbinds - ; return (catMaybes mb_binds) } +tcRecordBinds data_con arg_tys (HsRecFields rbinds dd) + = do { mb_binds <- mapM do_bind rbinds + ; return (HsRecFields (catMaybes mb_binds) dd) } where flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys - do_bind (L loc field_lbl, rhs) + do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs }) | Just field_ty <- assocMaybe flds_w_tys field_lbl = addErrCtxt (fieldCtxt field_lbl) $ - do { rhs' <- tcPolyExprNC rhs field_ty - ; sel_id <- tcLookupField field_lbl - ; ASSERT( isRecordSelector sel_id ) - return (Just (L loc sel_id, rhs')) } + do { rhs' <- tcPolyExprNC rhs field_ty + ; let field_id = mkUserLocal (nameOccName field_lbl) + (nameUnique field_lbl) + field_ty loc + -- Yuk: the field_id has the *unique* of the selector Id + -- (so we can find it easily) + -- but is a LocalId with the appropriate type of the RHS + -- (so the desugarer knows the type of local binder to make) + ; return (Just (fld { hsRecFieldId = L loc field_id, hsRecFieldArg = rhs' })) } | otherwise = do { addErrTc (badFieldCon data_con field_lbl) ; return Nothing } @@ -1073,33 +1424,33 @@ 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 - = if any isMarkedStrict field_strs then + = if any isBanged field_strs then -- Illegal if any arg is strict addErrTc (missingStrictFields data_con []) else - returnM () + return () - | otherwise -- A record - = checkM (null missing_s_fields) - (addErrTc (missingStrictFields data_con missing_s_fields)) `thenM_` + | otherwise = do -- A record + unless (null missing_s_fields) + (addErrTc (missingStrictFields data_con missing_s_fields)) - doptM Opt_WarnMissingFields `thenM` \ warn -> - checkM (not (warn && notNull missing_ns_fields)) + warn <- doptM Opt_WarnMissingFields + unless (not (warn && notNull missing_ns_fields)) (warnTc True (missingFields data_con missing_ns_fields)) where missing_s_fields = [ fl | (fl, str) <- field_info, - isMarkedStrict str, + isBanged str, not (fl `elem` field_names_used) ] missing_ns_fields = [ fl | (fl, str) <- field_info, - not (isMarkedStrict str), + not (isBanged str), not (fl `elem` field_names_used) ] - field_names_used = recBindFields rbinds + field_names_used = hsRecFields rbinds field_labels = dataConFieldLabels data_con field_info = zipEqual "missingFields" @@ -1117,38 +1468,61 @@ checkMissingFields data_con rbinds Boring and alphabetical: \begin{code} -caseScrutCtxt expr - = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr) +addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a +addExprErrCtxt expr = addErrCtxt (exprCtxt expr) +exprCtxt :: LHsExpr Name -> SDoc exprCtxt expr - = hang (ptext SLIT("In the expression:")) 4 (ppr expr) + = hang (ptext (sLit "In the expression:")) 2 (ppr expr) +fieldCtxt :: Name -> SDoc fieldCtxt field_name - = ptext SLIT("In the") <+> quotes (ppr field_name) <+> ptext SLIT("field of a record") + = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") +funAppCtxt :: LHsExpr Name -> LHsExpr Name -> Int -> SDoc funAppCtxt fun arg arg_no - = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"), + = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"), quotes (ppr fun) <> text ", namely"]) - 4 (quotes (ppr arg)) - -predCtxt expr - = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr) - -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")] + 2 (quotes (ppr arg)) + +funResCtxt :: LHsExpr Name -> TcType -> TcType + -> TidyEnv -> TcM (TidyEnv, Message) +-- When we have a mis-match in the return type of a function +-- try to give a helpful message about too many/few arguments +funResCtxt fun fun_res_ty res_ty env0 + = do { fun_res' <- zonkTcType fun_res_ty + ; res' <- zonkTcType res_ty + ; let n_fun = length (fst (tcSplitFunTys fun_res')) + n_res = length (fst (tcSplitFunTys res')) + what | n_fun > n_res = ptext (sLit "few") + | otherwise = ptext (sLit "many") + extra | n_fun == n_res = empty + | otherwise = ptext (sLit "Probable cause:") <+> quotes (ppr fun) + <+> ptext (sLit "is applied to too") <+> what + <+> ptext (sLit "arguments") + msg = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun) + ; return (env0, msg $$ extra) } + +badFieldTypes :: [(Name,TcType)] -> SDoc +badFieldTypes prs + = hang (ptext (sLit "Record update for insufficiently polymorphic field") + <> plural prs <> colon) + 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) + +badFieldsUpd :: HsRecFields Name a -> SDoc badFieldsUpd rbinds - = hang (ptext SLIT("No constructor has all these fields:")) - 4 (pprQuotedList (recBindFields rbinds)) + = hang (ptext (sLit "No constructor has all these fields:")) + 2 (pprQuotedList (hsRecFields rbinds)) +naughtyRecordSel :: TcId -> SDoc 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") + = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+> + ptext (sLit "as a function due to escaped type variables") $$ + ptext (sLit "Probable fix: use pattern-matching syntax instead") +notSelector :: Name -> SDoc notSelector field - = hsep [quotes (ppr field), ptext SLIT("is not a record selector")] + = hsep [quotes (ppr field), ptext (sLit "is not a record selector")] missingStrictFields :: DataCon -> [FieldLabel] -> SDoc missingStrictFields con fields @@ -1158,20 +1532,19 @@ missingStrictFields con fields -- with strict fields | otherwise = colon <+> pprWithCommas ppr fields - header = ptext SLIT("Constructor") <+> quotes (ppr con) <+> - ptext SLIT("does not have the required strict field(s)") + 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:") + = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:") <+> pprWithCommas ppr fields -callCtxt fun args - = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args)) +-- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args)) #ifdef GHCI polySpliceErr :: Id -> SDoc polySpliceErr id - = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id) + = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id) #endif \end{code}