X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=d7118e1f816bc84c29ad472aae75a97531cdf1e0;hp=804fb478907be2e4cb00d90d34a9fd5707153773;hb=215ce9f15215399ce30ae55c9521087847d78646;hpb=1d1c3c727617630beacacaf33022e1daba06a0bb diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 804fb47..d7118e1 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -12,7 +12,9 @@ -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcSyntaxOp) where +module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, + tcInferRho, tcInferRhoNC, tcSyntaxOp, + addExprErrCtxt ) where #include "HsVersions.h" @@ -57,6 +59,9 @@ import ListSetOps import Maybes import Outputable import FastString + +import Data.List( partition ) +import Control.Monad \end{code} %************************************************************************ @@ -77,46 +82,53 @@ tcPolyExpr, tcPolyExprNC -- to do so himself. tcPolyExpr expr res_ty - = addErrCtxt (exprCtxt (unLoc expr)) $ + = addExprErrCtxt 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 (\_ -> tcPolyExprNC expr) + ; (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 - = tcMonoExpr expr res_ty + = tcMonoExprNC expr res_ty --------------- tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId] -tcPolyExprs [] [] = returnM [] +tcPolyExprs [] [] = return [] tcPolyExprs (expr:exprs) (ty:tys) = do { expr' <- tcPolyExpr expr ty ; exprs' <- tcPolyExprs exprs tys - ; returnM (expr':exprs') } + ; return (expr':exprs') } tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys) --------------- -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 (L loc expr) res_ty +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 + -> TcM (LHsExpr TcId) + +tcMonoExpr expr res_ty + = addErrCtxt (exprCtxt expr) $ + tcMonoExprNC 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) +tcInferRho expr = tcInfer (tcMonoExpr expr) +tcInferRhoNC expr = tcInfer (tcMonoExprNC expr) \end{code} @@ -128,6 +140,9 @@ tcInferRho expr = tcInfer (tcMonoExpr expr) \begin{code} tcExpr :: HsExpr Name -> BoxyRhoType -> 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 (HsLit lit) res_ty = do { let lit_ty = hsLitType lit @@ -135,14 +150,14 @@ tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit ; return $ mkHsWrapCoI coi (HsLit lit) } -tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExpr expr 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 - ; returnM (HsSCC lbl expr') } + ; return (HsSCC lbl expr') } tcExpr (HsTickPragma info expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; returnM (HsTickPragma info expr') } + ; return (HsTickPragma info expr') } tcExpr (HsCoreAnn lbl expr) res_ty -- hdaume: core annotation = do { expr' <- tcMonoExpr expr res_ty @@ -189,9 +204,10 @@ tcExpr in_expr@(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 sig_tc_ty emptyVarSet (\ skol_tvs res_ty -> + ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (Just ExprSigCtxt) $ \ skol_tvs res_ty -> tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $ - tcPolyExprNC expr res_ty) + -- See Note [More instantiated than scoped] in TcBinds + tcMonoExprNC expr res_ty ; co_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty ; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) } @@ -221,35 +237,83 @@ tcExpr in_expr@(OpApp arg1 lop@(L loc op) fix arg2) res_ty -- \ x -> e op x, -- or -- \ x -> op e x, --- or just +-- or, if PostfixOperators is enabled, just -- op e -- --- We treat it as similar to the latter, so we don't +-- 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 really Haskell 98 --- I suppose, but it's less work and kind of useful. +-- 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 { (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty - ; return (SectionL arg1' (L loc op')) } + = 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, expr') + <- subFunTys doc 1 res_ty Nothing $ \ [arg2_ty'] res_ty' -> + do { (op', (arg1', co_arg2)) <- tcApp op 2 (tc_args arg2_ty') res_ty' + ; let coi = mkFunTyCoI arg2_ty' co_arg2 res_ty' IdCo + ; return (mkHsWrapCoI coi (SectionL arg1' (L loc op'))) } + ; return (mkHsWrap co_fn expr') } } + 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 { co_arg2 <- boxyUnify (substTyWith qtvs qtys arg2_ty) arg2_ty' + ; arg1' <- tcArg lop 1 arg1 qtvs qtys arg1_ty + ; qtys' <- mapM refineBox qtys -- c.f. tcArgs + ; return (qtys', (arg1', co_arg2)) } + tc_args _ _ _ _ = panic "tcExpr SectionL" -- 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 (mkHsWrap co_fn (SectionR (L loc op') arg2')) } + = do { (co_fn, expr') + <- subFunTys doc 1 res_ty Nothing $ \ [arg1_ty'] res_ty' -> + do { (op', (co_arg1, arg2')) <- tcApp op 2 (tc_args arg1_ty') res_ty' + ; let coi = mkFunTyCoI arg1_ty' co_arg1 res_ty' IdCo + ; return (mkHsWrapCoI coi $ SectionR (L loc op') arg2') } + ; return (mkHsWrap co_fn expr') } where - doc = ptext SLIT("The section") <+> quotes (ppr in_expr) - <+> ptext SLIT("takes one argument") + 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') } + = do { co_arg1 <- boxyUnify (substTyWith qtvs qtys arg1_ty) arg1_ty' + ; arg2' <- tcArg lop 2 arg2 qtvs qtys arg2_ty + ; qtys' <- mapM refineBox qtys -- c.f. tcArgs + ; return (qtys', (co_arg1, arg2')) } tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR" + +-- 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 in_expr@(ExplicitTuple tup_args boxity) res_ty + = do { let kind = case boxity of { Boxed -> liftedTypeKind + ; Unboxed -> argTypeKind } + arity = length tup_args + tup_tc = tupleTyCon boxity arity + mk_tup_res_ty arg_tys + = mkFunTys [ty | (ty, Missing _) <- arg_tys `zip` tup_args] + (mkTyConApp tup_tc arg_tys) + + ; checkWiredInTyCon tup_tc -- Ensure instances are available + ; tvs <- newBoxyTyVars (replicate arity kind) + ; let arg_tys1 = map mkTyVarTy tvs + ; arg_tys2 <- preSubType tvs (mkVarSet tvs) (mk_tup_res_ty arg_tys1) res_ty + + ; let go (Missing _, arg_ty) = return (Missing arg_ty) + go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty + ; return (Present expr') } + ; tup_args' <- mapM go (tup_args `zip` arg_tys2) + + ; arg_tys3 <- mapM refineBox arg_tys2 + ; co_fn <- tcSubExp TupleOrigin (mk_tup_res_ty arg_tys3) res_ty + ; return (mkHsWrap co_fn (ExplicitTuple tup_args' boxity)) } \end{code} \begin{code} @@ -268,8 +332,7 @@ 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) ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty @@ -279,8 +342,7 @@ tcExpr (HsCase scrut matches) exp_ty mc_body = tcBody } tcExpr (HsIf pred b1 b2) res_ty - = do { pred' <- addErrCtxt (predCtxt pred) $ - tcMonoExpr pred boolTy + = do { pred' <- tcMonoExpr pred boolTy ; b1' <- tcMonoExpr b1 res_ty ; b2' <- tcMonoExpr b2 res_ty ; return (HsIf pred' b1' b2') } @@ -288,17 +350,26 @@ 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 -- Non-empty list +tcExpr in_expr@(ExplicitList _ exprs) res_ty = do { (elt_ty, coi) <- boxySplitListTy res_ty - ; exprs' <- mappM (tc_elt elt_ty) exprs + ; 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' <- mappM (tc_elt elt_ty) exprs - ; ifM (null exprs) (zapToMonotype elt_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 @@ -307,32 +378,17 @@ tcExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty 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 { tvs <- newBoxyTyVars [argTypeKind | 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') } 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} %************************************************************************ @@ -361,151 +417,228 @@ tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty ; (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. + ; return (RecordCon (L loc (dataConWrapId data_con)) 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 expr@(RecordUpd record_expr rbinds _ _ _) res_ty - = -- STEP 0 + = ASSERT( notNull upd_fld_names ) + do { + -- STEP 0 -- Check that the field names are really field names - let - field_names = hsRecFields rbinds - in - ASSERT( notNull field_names ) - mappM tcLookupField 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) - | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids, - not (isRecordSelector sel_id), -- Excludes class ops - let L loc field_name = hsRecFieldId fld - ] - 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) - 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 - 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 = 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 = returnM result_inst_ty -- Same as result type - | otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind - in - ASSERT( null theta ) -- Vanilla datacon - tcInstTyVars con1_tyvars `thenM` \ (_, result_inst_tys, result_inst_env) -> - zipWithM mk_inst_ty con1_tyvars result_inst_tys `thenM` \ scrut_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 - in - tcSubExp origin result_ty res_ty `thenM` \ co_fn -> - tcRecordBinds con1 con1_arg_tys' rbinds `thenM` \ 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 - in - tcMonoExpr record_expr scrut_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 dataConStupidTheta tells us. - let - theta' = substTheta scrut_inst_env (dataConStupidTheta con1) - in - instStupidTheta origin theta' `thenM_` + -- 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, fixed_flds1_w_tys) = partition is_updated flds1_w_tys + is_updated (fld,ty) = 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 result_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 + + -- 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 + + ; let origin = RecordUpdOrigin + ; co_fn <- tcSubExp origin result_ty res_ty + + -- STEP 6: Deal with the stupid theta + ; let theta' = substTheta scrut_subst (dataConStupidTheta con1) + ; instStupidTheta origin 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 - = WpCo $ mkTyConApp co_con scrut_inst_tys - | otherwise - = idHsWrapper - in + ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon + = WpCast $ mkTyConApp co_con scrut_inst_tys + | otherwise + = idHsWrapper + -- Phew! - returnM (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds' - relevant_cons scrut_inst_tys result_inst_tys)) + ; return (mkHsWrap co_fn (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..] @@ -588,6 +721,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 _) res_ty = + pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e) #endif /* GHCI */ \end{code} @@ -715,12 +850,12 @@ tcId :: InstOrigin -> 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 - + = do { (fun, fun_ty) <- lookupFun orig fun_name + ; traceTc (text "tcId" <+> ppr fun_name <+> (ppr fun_ty $$ ppr res_ty)) + -- Split up the function type ; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy fun_ty - qtvs = concatMap fst tv_theta_prs -- Quantified tyvars + 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 @@ -728,6 +863,8 @@ tcId orig fun_name res_ty ; let res_subst = zipTopTvSubst qtvs qtv_tys fun_tau' = substTy res_subst fun_tau + ; traceTc (text "tcId2" <+> ppr fun_name <+> (ppr qtvs $$ ppr qtv_tys)) + ; co_fn <- tcSubExp orig fun_tau' res_ty -- And pack up the results @@ -762,9 +899,10 @@ tcId orig fun_name res_ty 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) +-- This version assumes ty is a monotype tcSyntaxOp orig (HsVar op) ty = tcId orig op ty -tcSyntaxOp orig other ty = pprPanic "tcSyntaxOp" (ppr other) - +tcSyntaxOp orig other ty = pprPanic "tcSyntaxOp" (ppr other) + --------------------------- instFun :: InstOrigin -> HsExpr TcId @@ -782,7 +920,8 @@ instFun orig fun subst tv_theta_prs ; doStupidChecks fun ty_theta_prs' -- Now do normal instantiation - ; result <- go True fun ty_theta_prs' + ; method_sharing <- doptM Opt_MethodSharing + ; result <- go method_sharing True fun ty_theta_prs' ; traceTc (text "instFun result" <+> ppr result) ; return result } @@ -790,24 +929,24 @@ instFun orig fun subst tv_theta_prs subst_pr (tvs, theta) = (substTyVars subst tvs, substTheta subst theta) - go _ fun [] = do {traceTc (text "go _ fun [] returns" <+> ppr fun) ; return fun } + go _ _ fun [] = do {traceTc (text "go _ _ fun [] returns" <+> ppr fun) ; return fun } - go True (HsVar fun_id) ((tys,theta) : prs) - | want_method_inst theta + 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 False (HsVar meth_id) prs } + ; go method_sharing False (HsVar meth_id) prs } -- Go round with 'False' to prevent further use -- of newMethod: see Note [Multiple instantiation] - go _ fun ((tys, theta) : prs) + go method_sharing _ fun ((tys, theta) : prs) = do { co_fn <- instCall orig tys theta ; traceTc (text "go yields co_fn" <+> ppr co_fn) - ; go False (HsWrap co_fn fun) prs } + ; go method_sharing False (HsWrap co_fn fun) prs } -- See Note [No method sharing] - want_method_inst theta = not (null theta) -- Overloaded - && not opt_NoMethodSharing + want_method_inst method_sharing theta = not (null theta) -- Overloaded + && method_sharing \end{code} Note [Multiple instantiation] @@ -877,7 +1016,7 @@ tcArgs :: LHsExpr Name -- The function (for error messages) type ArgChecker results = [TyVar] -> [TcSigmaType] -- Current instantiation -> [TcSigmaType] -- Expected arg types (**before** applying the instantiation) - -> TcM ([TcSigmaType], results) -- Resulting instaniation and args + -> TcM ([TcSigmaType], results) -- Resulting instantiation and args tcArgs fun args qtvs qtys arg_tys = go 1 qtys args arg_tys @@ -944,12 +1083,12 @@ doStupidChecks fun tv_theta_prs 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")]) + = 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")]) where at_type | null tys = empty -- Probably never happens - | otherwise = ptext SLIT("at type") <+> ppr (head tys) + | otherwise = ptext (sLit "at type") <+> ppr (head tys) \end{code} %************************************************************************ @@ -974,35 +1113,47 @@ lookupFun orig id_name -- nor does it need the 'lifting' treatment ATcId { tct_id = id, tct_type = ty, tct_co = mb_co, tct_level = lvl } + | isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id) + -- Note [Local record selectors] + | otherwise -> 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)")) + 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")) + other -> failWithTc (ppr other <+> ptext (sLit "used where a value identifer was expected")) } #ifndef GHCI /* GHCI and TH is off */ -------------------------------------- --- thLocalId : Check for cross-stage lifting -thLocalId orig id id_ty th_bind_lvl +thLocalId :: InstOrigin -> Id -> TcType -> ThLevel -> TcM () +-- Check for cross-stage lifting +thLocalId orig id id_ty bind_lvl = return () #else /* GHCI and TH is on */ -thLocalId orig id id_ty th_bind_lvl +thLocalId orig id id_ty 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 (text "thLocalId" <+> ppr id <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl) + ; when (use_lvl > bind_lvl) $ + checkCrossStageLifting orig id id_ty bind_lvl use_stage } -------------------------------------- -thBrackId orig id ps_var lie_var +checkCrossStageLifting :: InstOrigin -> Id -> TcType -> 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 orig id id_ty bind_lvl (Brack _ ps_var lie_var) | thTopLevelId id = -- Top-level identifiers in this module, -- (which have External Names) @@ -1014,9 +1165,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 @@ -1026,8 +1178,7 @@ thBrackId orig id ps_var lie_var -- If 'x' occurs many times we may get many identical -- bindings of the same splice proxy, but that doesn't -- matter, although it's a mite untidy. - do { let id_ty = idType id - ; checkTc (isTauTy id_ty) (polySpliceErr id) + do { 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 @@ -1040,18 +1191,39 @@ thBrackId orig id ps_var lie_var -- 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 + tcLookupId DsMeta.liftStringName + -- See Note [Lifting strings] + else + setLIEVar lie_var $ do -- Put the 'lift' constraint into the right LIE + newMethodFromName orig id_ty' DsMeta.liftName -- Update the pending splices ; ps <- readMutVar ps_var ; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar 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. + %************************************************************************ %* * @@ -1084,17 +1256,22 @@ tcRecordBinds -> TcM (HsRecordBinds TcId) tcRecordBinds data_con arg_tys (HsRecFields rbinds dd) - = do { mb_binds <- mappM do_bind rbinds + = 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 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 } @@ -1103,29 +1280,29 @@ 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) ] @@ -1147,39 +1324,36 @@ 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 :: OutputableBndr id => LHsExpr id -> TcM a -> TcM a +addExprErrCtxt expr = addErrCtxt (exprCtxt (unLoc expr)) exprCtxt expr - = hang (ptext SLIT("In the expression:")) 4 (ppr expr) + = hang (ptext (sLit "In the expression:")) 4 (ppr expr) 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 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) +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 rbinds - = hang (ptext SLIT("No constructor has all these fields:")) + = hang (ptext (sLit "No constructor has all these fields:")) 4 (pprQuotedList (hsRecFields rbinds)) 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 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 @@ -1189,19 +1363,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}