X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=72052876f97f1bcb33907a0becb606af62fe8e0f;hp=721c57cf7fb46404693d9b4693774c063869631d;hb=b10d7d079ec9c3fc22d4700fe484dd297bddb805;hpb=de29097709338f70a0356959dea4c5643f0a6fc7 diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 721c57c..7205287 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -5,14 +5,16 @@ \section[TcExpr]{Typecheck an expression} \begin{code} -{-# OPTIONS -w #-} -- 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, tcInferRho, tcInferRhoNC, tcSyntaxOp ) where +module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, + tcInferRho, tcInferRhoNC, + tcSyntaxOp, tcCheckId, + addExprErrCtxt ) where #include "HsVersions.h" @@ -35,29 +37,25 @@ import TcHsType import TcPat import TcMType import TcType -import TcIface ( checkWiredInTyCon ) import Id import DataCon import Name import TyCon import Type -import TypeRep import Coercion import Var import VarSet import TysWiredIn +import TysPrim( intPrimTy ) +import PrimOp( tagToEnumKey ) import PrelNames -import PrimOp import DynFlags -import StaticFlags -import HscTypes import SrcLoc import Util import ListSetOps import Maybes import Outputable import FastString - import Control.Monad \end{code} @@ -69,47 +67,30 @@ import Control.Monad \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 expr) $ - (do {traceTc (text "tcPolyExpr") ; tcPolyExprNC expr res_ty }) - -tcPolyExprNC expr res_ty - | isSigmaTy res_ty - = do { traceTc (text "tcPolyExprNC" <+> ppr res_ty) - ; (gen_fn, expr') <- tcGen res_ty emptyVarSet Nothing $ \ _ res_ty -> - tcPolyExprNC expr res_ty - -- Note the recursive call to tcPolyExpr, because the - -- type may have multiple layers of for-alls - -- E.g. forall a. Eq a => forall b. Ord b => .... - ; return (mkLHsWrap gen_fn expr') } - - | otherwise - = tcMonoExprNC expr res_ty + = addExprErrCtxt expr $ + do { traceTc "tcPolyExpr" (ppr res_ty); tcPolyExprNC expr res_ty } ---------------- -tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId] -tcPolyExprs [] [] = return [] -tcPolyExprs (expr:exprs) (ty:tys) - = do { expr' <- tcPolyExpr expr ty - ; exprs' <- tcPolyExprs exprs tys - ; return (expr':exprs') } -tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys) +tcPolyExprNC expr res_ty + = do { traceTc "tcPolyExprNC" (ppr res_ty) + ; (gen_fn, expr') <- tcGen (GenSkol res_ty) res_ty $ \ _ rho -> + tcMonoExprNC expr rho + ; return (mkLHsWrap gen_fn expr') } --------------- tcMonoExpr, tcMonoExprNC - :: 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 + :: LHsExpr Name -- Expression to type check + -> TcRhoType -- Expected type (could be a type variable) + -- Definitely no foralls at the top -> TcM (LHsExpr TcId) tcMonoExpr expr res_ty @@ -124,8 +105,27 @@ tcMonoExprNC (L loc expr) res_ty --------------- tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) -tcInferRho expr = tcInfer (tcMonoExpr expr) -tcInferRhoNC expr = tcInfer (tcMonoExprNC expr) +-- 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} @@ -136,32 +136,34 @@ tcInferRhoNC expr = tcInfer (tcMonoExprNC expr) %************************************************************************ \begin{code} -tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId) +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 = tcId (OccurrenceOf name) name res_ty +tcExpr (HsVar name) res_ty = tcCheckId name res_ty + +tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty -tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit - ; coi <- boxyUnify lit_ty res_ty - ; return $ mkHsWrapCoI coi (HsLit lit) - } +tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit + ; tcWrapResult (HsLit lit) lit_ty res_ty } -tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty - ; return (HsPar expr') } +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 (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') } + = do { expr' <- tcMonoExpr expr res_ty + ; return (HsTickPragma info expr') } -tcExpr (HsCoreAnn lbl expr) res_ty -- hdaume: core annotation +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 + = do { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty ; return (HsOverLit lit') } tcExpr (NegApp expr neg_expr) res_ty @@ -177,39 +179,29 @@ tcExpr (HsIPVar ip) res_ty -- 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 origin ip_ty res_ty - ; (ip', inst) <- newIPDict origin ip ip_ty - ; extendLIE inst - ; return (mkHsWrap 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 - ; traceTc (text "tcExpr args': " <+> ppr args') - ; return (unLoc (foldl mkHsApp (L loc fun') args')) } + ; 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 (mkHsWrap co_fn (HsLam match')) } -tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty - = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty +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 (SigSkol 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 - -- Remember to extend the lexical type-variable environment - ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (Just ExprSigCtxt) $ \ skol_tvs res_ty -> - tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $ - -- See Note [More instantiated than scoped] in TcBinds - tcMonoExprNC expr res_ty + ; let inner_expr = ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty - ; co_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty - ; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) } + ; (inst_wrap, rho) <- deeplyInstantiate ExprSigOrigin sig_tc_ty + ; tcWrapResult (mkHsWrap inst_wrap inner_expr) rho res_ty } -tcExpr (HsType ty) 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) @@ -225,62 +217,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, if PostfixOperators is enabled, just --- op e --- --- 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. - -tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty - = do dflags <- getDOpts - if dopt Opt_PostfixOperators dflags - then do (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty - return (SectionL arg1' (L loc op')) - else do (co_fn, (op', arg1')) - <- subFunTys doc 1 res_ty Nothing - $ \ [arg2_ty'] res_ty' -> - tcApp op 2 (tc_args arg2_ty') res_ty' - return (mkHsWrap co_fn (SectionL arg1' (L loc op'))) - where - doc = ptext (sLit "The section") <+> quotes (ppr in_expr) - <+> ptext (sLit "takes one argument") - tc_args arg2_ty' qtvs qtys [arg1_ty, arg2_ty] - = do { boxyUnify arg2_ty' (substTyWith qtvs qtys arg2_ty) - ; arg1' <- tcArg lop 2 arg1 qtvs qtys arg1_ty - ; qtys' <- mapM refineBox qtys -- c.f. tcArgs - ; return (qtys', arg1') } - tc_args _ _ _ _ = panic "tcExpr SectionL" +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 $ mkHsWrapCoI co_res $ + OpApp (mkLHsWrapCoI 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 $ mkHsWrapCoI co_res $ + OpApp arg1' (mkLHsWrapCoI 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 Nothing $ \ [arg1_ty'] res_ty' -> - tcApp op 2 (tc_args arg1_ty') res_ty' - ; return (mkHsWrap 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 $ mkHsWrapCoI co_res $ + SectionR (mkLHsWrapCoI 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 $ mkHsWrapCoI co_res $ + SectionL arg1' (mkLHsWrapCoI 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 $ mkHsWrapCoI 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 $ mkHsWrapCoI 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 $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') } where - doc = ptext (sLit "The section") <+> quotes (ppr in_expr) - <+> ptext (sLit "takes one argument") - tc_args arg1_ty' qtvs qtys [arg1_ty, arg2_ty] - = do { boxyUnify arg1_ty' (substTyWith qtvs qtys arg1_ty) - ; arg2' <- tcArg lop 2 arg2 qtvs qtys arg2_ty - ; qtys' <- mapM refineBox qtys -- c.f. tcArgs - ; return (qtys', arg2') } - tc_args arg1_ty' _ _ _ = 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 $ mkHsWrapCoI 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 $ @@ -299,7 +385,7 @@ tcExpr (HsCase scrut matches) exp_ty -- first, to get type info that may be refined in the case alternatives (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 @@ -315,51 +401,6 @@ tcExpr (HsIf pred b1 b2) res_ty tcExpr (HsDo do_or_lc stmts body _) res_ty = tcDoStmts do_or_lc stmts body res_ty -tcExpr in_expr@(ExplicitList _ exprs) res_ty - = do { (elt_ty, coi) <- boxySplitListTy res_ty - ; exprs' <- mapM (tc_elt elt_ty) exprs - ; when (null exprs) (zapToMonotype elt_ty >> return ()) - -- If there are no expressions in the comprehension - -- we must still fill in the box - -- - -- The GHC front end never generates an empty ExplicitList - -- (instead it generates the [] data constructor) but - -- Template Haskell might. We could fix the bit of - -- TH that generates ExplicitList, but it seems less - -- fragile to just handle the case here. - ; return $ mkHsWrapCoI coi (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, coi) <- boxySplitPArrTy res_ty - ; exprs' <- mapM (tc_elt elt_ty) exprs - ; when (null exprs) (zapToMonotype elt_ty >> return ()) - -- 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 $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') } - where - tc_elt elt_ty expr = tcPolyExpr expr elt_ty - --- For tuples, take care to preserve rigidity --- E.g. case (x,y) of .... --- The scrutinee should have a rigid type if x,y do --- The general scheme is the same as in tcIdApp -tcExpr (ExplicitTuple exprs boxity) res_ty - = do { let kind = case boxity of { Boxed -> liftedTypeKind - ; Unboxed -> argTypeKind } - ; tvs <- newBoxyTyVars [kind | e <- exprs] - ; let tup_tc = tupleTyCon boxity (length exprs) - tup_res_ty = mkTyConApp tup_tc (mkTyVarTys tvs) - ; checkWiredInTyCon tup_tc -- Ensure instances are available - ; arg_tys <- preSubType tvs (mkVarSet tvs) tup_res_ty res_ty - ; exprs' <- tcPolyExprs exprs arg_tys - ; arg_tys' <- mapM refineBox arg_tys - ; co_fn <- tcSubExp TupleOrigin (mkTyConApp tup_tc arg_tys') res_ty - ; return (mkHsWrap co_fn (ExplicitTuple exprs' boxity)) } - tcExpr (HsProc pat cmd) res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty ; return $ mkHsWrapCoI coi (HsProc pat' cmd') } @@ -380,169 +421,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 qtvs qtys arg_tys - = do { let arg_tys' = substTys (zipOpenTvSubst qtvs qtys) arg_tys - ; rbinds' <- tcRecordBinds data_con arg_tys' rbinds - ; qtys' <- mapM refineBoxToTau qtys - ; return (qtys', rbinds') } - -- The refineBoxToTau ensures that all the boxes in arg_tys are indeed - -- filled, which is the invariant expected by tcIdApp - -- How could this not be the case? Consider a record construction - -- that does not mention all the fields. - - ; (con_expr, rbinds') <- tcIdApp con_name arity check_fields res_ty - - ; return (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 = do + (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 $ mkHsWrapCoI 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 - let - field_names = hsRecFields rbinds - - MASSERT( notNull field_names ) - sel_ids <- mapM tcLookupField field_names - -- The renamer has already checked that they - -- are all in scope - let - bad_guys = [ setSrcSpan loc $ addErrTc (notSelector field_name) - | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids, - not (isRecordSelector sel_id), -- Excludes class ops - let L loc field_name = hsRecFieldId fld - ] - - unless (null bad_guys) (sequence bad_guys >> failM) + ; 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) - 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) field_names - - -- 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) - - -- 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) - - -- 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 = ASSERT( not (null relevant_cons) ) head relevant_cons -- A representative constructor - (con1_tyvars, theta, con1_arg_tys, con1_res_ty) = dataConSig con1 - con1_flds = dataConFieldLabels con1 - common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys - , not (fld `elem` field_names) ] - - is_common_tv tv = tv `elemVarSet` common_tyvars - - mk_inst_ty tv result_inst_ty - | is_common_tv tv = return result_inst_ty -- Same as result type - | otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind - - MASSERT( null theta ) -- Vanilla datacon - (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tyvars - scrut_inst_tys <- zipWithM mk_inst_ty con1_tyvars result_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_ty = substTy result_inst_env con1_res_ty - con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys - origin = RecordUpdOrigin - - co_fn <- tcSubExp origin result_ty res_ty - rbinds' <- tcRecordBinds con1 con1_arg_tys' rbinds - - -- STEP 5: Typecheck the expression to be updated - let - scrut_inst_env = zipTopTvSubst con1_tyvars scrut_inst_tys - scrut_ty = substTy scrut_inst_env con1_res_ty - -- This is one place where the isVanilla check is important - -- So that inst_tys matches the con1_tyvars - - record_expr' <- tcMonoExpr record_expr scrut_ty - - -- 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 dataConStupidTheta tells us. - let - theta' = substTheta scrut_inst_env (dataConStupidTheta con1) - - instStupidTheta origin theta' + -- 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 = substTy result_inst_env con1_res_ty + con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys + scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys + scrut_ty = substTy scrut_subst con1_res_ty + + ; co_res <- unifyType rec_res_ty res_ty + + -- STEP 5 + -- 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 $ mkTyConApp co_con scrut_inst_tys - | otherwise - = idHsWrapper - + ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon + = WpCast $ mkTyConApp co_con scrut_inst_tys + | otherwise + = idHsWrapper -- Phew! - return (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds' - relevant_cons scrut_inst_tys result_inst_tys)) + ; return $ mkHsWrapCoI 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..] @@ -553,58 +666,58 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty = do \begin{code} tcExpr (ArithSeq _ seq@(From expr)) res_ty - = do { (elt_ty, coi) <- boxySplitListTy res_ty + = do { (coi, elt_ty) <- matchExpectedListTy res_ty ; expr' <- tcPolyExpr expr elt_ty ; enum_from <- newMethodFromName (ArithSeqOrigin seq) - elt_ty enumFromName - ; return $ mkHsWrapCoI coi (ArithSeq (HsVar enum_from) (From expr')) } + enumFromName elt_ty + ; return $ mkHsWrapCoI coi (ArithSeq enum_from (From expr')) } -tcExpr in_expr@(ArithSeq _ seq@(FromThen expr1 expr2)) res_ty - = do { (elt_ty, coi) <- 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 + enumFromThenName elt_ty ; return $ mkHsWrapCoI coi - (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) } + (ArithSeq enum_from_then (FromThen expr1' expr2')) } -tcExpr in_expr@(ArithSeq _ seq@(FromTo expr1 expr2)) res_ty - = do { (elt_ty, coi) <- 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 + enumFromToName elt_ty ; return $ mkHsWrapCoI coi - (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) } + (ArithSeq enum_from_to (FromTo expr1' expr2')) } -tcExpr in_expr@(ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty - = do { (elt_ty, coi) <- 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 + enumFromThenToName elt_ty ; return $ mkHsWrapCoI coi - (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) } + (ArithSeq eft (FromThenTo expr1' expr2' expr3')) } -tcExpr in_expr@(PArrSeq _ seq@(FromTo expr1 expr2)) res_ty - = do { (elt_ty, coi) <- boxySplitPArrTy 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 + enumFromToPName elt_ty ; return $ mkHsWrapCoI coi - (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) } + (PArrSeq enum_from_to (FromTo expr1' expr2')) } -tcExpr in_expr@(PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty - = do { (elt_ty, coi) <- boxySplitPArrTy 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 + enumFromThenToPName elt_ty ; return $ mkHsWrapCoI coi - (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) } + (PArrSeq eft (FromThenTo expr1' expr2' expr3')) } tcExpr (PArrSeq _ _) _ = panic "TcExpr.tcMonoExpr: Infinite parallel array!" @@ -625,7 +738,7 @@ 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 _) res_ty = +tcExpr e@(HsQuasiQuoteE _) _ = pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e) #endif /* GHCI */ \end{code} @@ -649,205 +762,223 @@ tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) %************************************************************************ \begin{code} +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 <- unifyType actual_res_ty res_ty + + -- Typecheck the arguments + ; args1 <- tcArgs fun args expected_arg_tys + + -- Assemble the result + ; let fun2 = mkLHsWrapCoI co_fun fun1 + app = mkLHsWrapCoI 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 = mkLHsWrapCoI 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 + +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, 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) + +---------------- +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 (CoercionI, [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") + --------------------------- -tcApp :: HsExpr Name -- Function - -> Arity -- Number of args reqd - -> ArgChecker results - -> BoxyRhoType -- Result type - -> TcM (HsExpr TcId, results) +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} --- (tcFun fun n_args arg_checker res_ty) --- The argument type checker, arg_checker, will be passed exactly n_args types -tcApp (HsVar fun_name) n_args arg_checker res_ty - = tcIdApp fun_name n_args arg_checker res_ty +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. -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' -- Yuk - ; return (fun', args') } +Here's an example where it actually makes a real difference ---------------------------- -tcIdApp :: Name -- Function - -> Arity -- Number of args reqd - -> ArgChecker results -- The arg-checker guarantees to fill all boxes in the arg types - -> BoxyRhoType -- Result type - -> TcM (HsExpr TcId, 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' - - -- Typecheck the arguments! - -- Doing so will fill arg_qtvs and extra_arg_tys' - ; (qtys'', args') <- arg_checker qtvs qtys' (fun_arg_tys ++ extra_arg_tys') - - -- Strip boxes from the qtvs that have been filled in by the arg checking - ; extra_arg_tys'' <- mapM readFilledBox extra_arg_boxes - - -- Result subsumption - -- This fills in res_qtvs - ; 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 <- tcSubExp orig 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 (substTys res_subst fun_arg_tys) co_fn - ; traceTc (text "tcIdApp: " <+> ppr (mkHsWrap co_fn' fun') <+> ppr tv_theta_prs <+> ppr co_fn' <+> ppr fun') - ; return (mkHsWrap co_fn' fun', args') } -\end{code} + class C t a b | t a -> b + instance C Char a Bool -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. + data P t a = forall b. (C t a b) => MkP b + data Q t = MkQ (forall a. P t a) -\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 <- tcSubExp orig fun_tau' res_ty - - -- And pack up the results - ; fun' <- instFun orig fun res_subst tv_theta_prs - ; traceTc (text "tcId yields" <+> ppr (mkHsWrap co_fn fun')) - ; return (mkHsWrap 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.] + f1, f2 :: Q Char; + f1 = MkQ (MkP True) + f2 = MkQ (MkP True :: forall a. P Char a) ---------------------------- -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) +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 :: InstOrigin - -> HsExpr TcId - -> TvSubst -- The instantiating substitution - -> [([TyVar], ThetaType)] -- Stuff to instantiate - -> TcM (HsExpr TcId) - -instFun orig fun subst [] - = return fun -- Common short cut - -instFun orig fun subst tv_theta_prs - = do { let ty_theta_prs' = map subst_pr tv_theta_prs - ; traceTc (text "instFun" <+> ppr ty_theta_prs') - -- Make two ad-hoc checks - ; doStupidChecks fun ty_theta_prs' - - -- Now do normal instantiation - ; method_sharing <- doptM Opt_MethodSharing - ; result <- go method_sharing True fun ty_theta_prs' - ; traceTc (text "instFun result" <+> ppr result) - ; return result - } + +%************************************************************************ +%* * + 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 <- lookup_id + ; (id_expr, id_rho) <- instantiateOuter orig id + ; (wrap, rho) <- deeplyInstantiate orig id_rho + ; return (mkHsWrap wrap id_expr, rho) } where - subst_pr (tvs, theta) - = (substTyVars subst tvs, substTheta subst theta) - - go _ _ fun [] = do {traceTc (text "go _ _ fun [] returns" <+> ppr fun) ; return fun } - - go method_sharing True (HsVar fun_id) ((tys,theta) : prs) - | want_method_inst method_sharing theta - = do { traceTc (text "go (HsVar fun_id) ((tys,theta) : prs) | want_method_inst theta") - ; meth_id <- newMethodWithGivenTy orig fun_id tys - ; go method_sharing False (HsVar meth_id) prs } - -- Go round with 'False' to prevent further use - -- of newMethod: see Note [Multiple instantiation] - - go method_sharing _ fun ((tys, theta) : prs) - = do { co_fn <- instCall orig tys theta - ; traceTc (text "go yields co_fn" <+> ppr co_fn) - ; go method_sharing False (HsWrap co_fn fun) prs } - - -- See Note [No method sharing] - want_method_inst method_sharing theta = not (null theta) -- Overloaded - && method_sharing + lookup_id :: TcM TcId + lookup_id + = do { thing <- tcLookup id_name + ; case thing of + ATcId { tct_id = id, tct_level = lvl } + -> do { check_naughty id -- Note [Local record selectors] + ; checkThLocalId id lvl + ; return id } + + AGlobal (AnId id) + -> do { check_naughty id; return id } + -- A global cannot possibly be ill-staged + -- 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) + + | 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), substTy subst tau) } + where + (tvs, theta, tau) = tcSplitSigmaTy (idType id) \end{code} Note [Multiple instantiation] @@ -899,54 +1030,34 @@ This gets a bit less sharing, but a) it's better for RULEs involving overloaded functions b) perhaps fewer separated lambdas -Note [Left to right] -~~~~~~~~~~~~~~~~~~~~ -tcArgs implements a left-to-right order, which goes beyond what is described in the -impredicative type inference paper. In particular, it allows - runST $ foo -where runST :: (forall s. ST s a) -> a -When typechecking the application of ($)::(a->b) -> a -> b, we first check that -runST has type (a->b), thereby filling in a=forall s. ST s a. Then we un-box this type -before checking foo. The left-to-right order really helps here. - \begin{code} -tcArgs :: LHsExpr Name -- The function (for error messages) - -> [LHsExpr Name] -- Actual args - -> ArgChecker [LHsExpr TcId] +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) -type ArgChecker results - = [TyVar] -> [TcSigmaType] -- Current instantiation - -> [TcSigmaType] -- Expected arg types (**before** applying the instantiation) - -> TcM ([TcSigmaType], results) -- Resulting instaniation and args +doStupidChecks fun_id tys + | Just con <- isDataConId_maybe fun_id -- (a) + = addDataConStupidTheta con tys -tcArgs fun args qtvs qtys arg_tys - = go 1 qtys args arg_tys - where - go n qtys [] [] = return (qtys, []) - go n qtys (arg:args) (arg_ty:arg_tys) - = do { arg' <- tcArg fun n arg qtvs qtys arg_ty - ; qtys' <- mapM refineBox qtys -- Exploit new info - ; (qtys'', args') <- go (n+1) qtys' args arg_tys - ; return (qtys'', arg':args') } - go n qtys args arg_tys = panic "tcArgs" - -tcArg :: LHsExpr Name -- The function - -> Int -- and arg number (for error messages) - -> LHsExpr Name - -> [TyVar] -> [TcSigmaType] -- Instantiate the arg type like this - -> BoxySigmaType - -> TcM (LHsExpr TcId) -- Resulting argument -tcArg fun arg_no arg qtvs qtys ty - = addErrCtxt (funAppCtxt fun arg arg_no) $ - tcPolyExprNC arg (substTyWith qtvs qtys ty) + | 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 @@ -955,94 +1066,107 @@ 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. -\begin{code} -doStupidChecks :: HsExpr TcId - -> [([TcType], ThetaType)] - -> 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) --- (b) deal with the tagToEnum# problem: see Note [tagToEnum#] - -doStupidChecks (HsVar fun_id) ((tys,_):_) - | Just con <- isDataConId_maybe fun_id -- (a) - = addDataConStupidTheta con tys - - | fun_id `hasKey` tagToEnumKey -- (b) - = do { tys' <- zonkTcTypes tys - ; checkTc (ok tys') (tagToEnumError tys') - } - where - ok [] = False - ok (ty:tys) = case tcSplitTyConApp_maybe ty of - Just (tc,_) -> isEnumerationTyCon tc - Nothing -> False - -doStupidChecks fun tv_theta_prs - = return () -- The common case - +It's all grotesquely complicated. -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")]) +\begin{code} +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 (mkHsWrapCoI 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 (CoercionI, 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 (IdCo 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 ( ACo (mkSymCoercion (mkTyConApp 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@ typechecks 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 - Unrefineable -> return (HsVar id, ty) - Rigid co -> return (mkHsWrap co (HsVar id), ty) - Wobbly -> traceTc (text "lookupFun" <+> ppr id) >> return (HsVar id, ty) -- Wobbly, or no free vars - WobblyInvisible -> failWithTc (ppr id_name <+> ptext (sLit " not in scope because it has a wobbly type (solution: add a type annotation)")) - } - - 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 +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) @@ -1054,9 +1178,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; 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 @@ -1067,31 +1192,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 ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps) + ; writeMutVar ps_var ((idName id, nlHsApp (noLoc lift) (nlHsVar id)) : ps) - ; return 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. + %************************************************************************ %* * @@ -1131,10 +1274,15 @@ tcRecordBinds data_con arg_tys (HsRecFields rbinds dd) 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 (fld { hsRecFieldId = L loc sel_id, hsRecFieldArg = 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 } @@ -1143,7 +1291,7 @@ 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 @@ -1160,12 +1308,12 @@ checkMissingFields data_con rbinds 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) ] @@ -1187,31 +1335,41 @@ checkMissingFields data_con rbinds Boring and alphabetical: \begin{code} -exprCtxt (L _ expr) - = hang (ptext (sLit "In the 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:")) 2 (ppr expr) +fieldCtxt :: Name -> SDoc fieldCtxt field_name = 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"), quotes (ppr fun) <> text ", namely"]) - 4 (quotes (ppr arg)) + 2 (quotes (ppr arg)) + +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 ]) -nonVanillaUpd tycon - = vcat [ptext (sLit "Record update for the non-Haskell-98 data type") - <+> quotes (pprSourceTyCon tycon) - <+> ptext (sLit "is not (yet) supported"), - ptext (sLit "Use pattern-matching instead")] +badFieldsUpd :: HsRecFields Name a -> SDoc badFieldsUpd rbinds = hang (ptext (sLit "No constructor has all these fields:")) - 4 (pprQuotedList (hsRecFields rbinds)) + 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 "Probable fix: use pattern-matching syntax instead") +notSelector :: Name -> SDoc notSelector field = hsep [quotes (ppr field), ptext (sLit "is not a record selector")]