diff options
author | Jan Stolarek <jan.stolarek@p.lodz.pl> | 2016-01-15 18:24:14 +0100 |
---|---|---|
committer | Jan Stolarek <jan.stolarek@p.lodz.pl> | 2016-01-18 18:54:10 +0100 |
commit | b8abd852d3674cb485490d2b2e94906c06ee6e8f (patch) | |
tree | eddf226b9c10be8b9b982ed29c1ef61841755c6f /compiler/deSugar | |
parent | 817dd925569d981523bbf4fb471014d46c51c7db (diff) | |
download | haskell-b8abd852d3674cb485490d2b2e94906c06ee6e8f.tar.gz |
Replace calls to `ptext . sLit` with `text`
Summary:
In the past the canonical way for constructing an SDoc string literal was the
composition `ptext . sLit`. But for some time now we have function `text` that
does the same. Plus it has some rules that optimize its runtime behaviour.
This patch takes all uses of `ptext . sLit` in the compiler and replaces them
with calls to `text`. The main benefits of this patch are clener (shorter) code
and less dependencies between module, because many modules now do not need to
import `FastString`. I don't expect any performance benefits - we mostly use
SDocs to report errors and it seems there is little to be gained here.
Test Plan: ./validate
Reviewers: bgamari, austin, goldfire, hvr, alanz
Subscribers: goldfire, thomie, mpickering
Differential Revision: https://phabricator.haskell.org/D1784
Diffstat (limited to 'compiler/deSugar')
-rw-r--r-- | compiler/deSugar/Check.hs | 34 | ||||
-rw-r--r-- | compiler/deSugar/Coverage.hs | 10 | ||||
-rw-r--r-- | compiler/deSugar/Desugar.hs | 22 | ||||
-rw-r--r-- | compiler/deSugar/DsArrows.hs | 3 | ||||
-rw-r--r-- | compiler/deSugar/DsBinds.hs | 38 | ||||
-rw-r--r-- | compiler/deSugar/DsExpr.hs | 14 | ||||
-rw-r--r-- | compiler/deSugar/DsForeign.hs | 24 | ||||
-rw-r--r-- | compiler/deSugar/DsListComp.hs | 5 | ||||
-rw-r--r-- | compiler/deSugar/DsMeta.hs | 2 | ||||
-rw-r--r-- | compiler/deSugar/DsMonad.hs | 12 | ||||
-rw-r--r-- | compiler/deSugar/MatchLit.hs | 16 | ||||
-rw-r--r-- | compiler/deSugar/PmExpr.hs | 5 |
12 files changed, 91 insertions, 94 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 5d8a1717ed..de53a4af6e 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -1408,15 +1408,15 @@ isAnyPmCheckEnabled dflags (DsMatchContext kind _loc) warnManyGuards :: DsMatchContext -> DsM () warnManyGuards (DsMatchContext kind loc) = putSrcSpanDs loc $ warnDs $ vcat - [ sep [ ptext (sLit "Too many guards in") <+> pprMatchContext kind - , ptext (sLit "Guard checking has been over-simplified") ] - , parens (ptext (sLit "Use:") <+> (opt_1 $$ opt_2)) ] + [ sep [ text "Too many guards in" <+> pprMatchContext kind + , text "Guard checking has been over-simplified" ] + , parens (text "Use:" <+> (opt_1 $$ opt_2)) ] where - opt_1 = hang (ptext (sLit "-Wno-too-many-guards")) 2 $ - ptext (sLit "to suppress this warning") - opt_2 = hang (ptext (sLit "-ffull-guard-reasoning")) 2 $ vcat - [ ptext (sLit "to run the full checker (may increase") - , ptext (sLit "compilation time and memory consumption)") ] + opt_1 = hang (text "-Wno-too-many-guards") 2 $ + text "to suppress this warning" + opt_2 = hang (text "-ffull-guard-reasoning") 2 $ vcat + [ text "to run the full checker (may increase" + , text "compilation time and memory consumption)" ] dsPmWarn :: DynFlags -> DsMatchContext -> DsM PmResult -> DsM () dsPmWarn dflags ctx@(DsMatchContext kind loc) mPmResult @@ -1438,15 +1438,15 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) mPmResult pprEqns qs text = pp_context ctx (ptext (sLit text)) $ \f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ dots qs - pprEqnsU qs = pp_context ctx (ptext (sLit "are non-exhaustive")) $ \_ -> + pprEqnsU qs = pp_context ctx (text "are non-exhaustive") $ \_ -> case qs of -- See #11245 - [([],_)] -> ptext (sLit "Guards do not cover entire pattern space") + [([],_)] -> text "Guards do not cover entire pattern space" _missing -> let us = map ppr_uncovered qs - in hang (ptext (sLit "Patterns not matched:")) 4 + in hang (text "Patterns not matched:") 4 (vcat (take maximum_output us) $$ dots us) dots :: [a] -> SDoc -dots qs | qs `lengthExceeds` maximum_output = ptext (sLit "...") +dots qs | qs `lengthExceeds` maximum_output = text "..." | otherwise = empty exhaustive :: DynFlags -> HsMatchContext id -> Bool @@ -1467,8 +1467,8 @@ exhaustive _dflags (StmtCtxt {}) = False -- Don't warn about incomplete patterns pp_context :: DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun - = vcat [ptext (sLit "Pattern match(es)") <+> msg, - sep [ ptext (sLit "In") <+> ppr_match <> char ':' + = vcat [text "Pattern match(es)" <+> msg, + sep [ text "In" <+> ppr_match <> char ':' , nest 4 (rest_of_msg_fun pref)]] where (ppr_match, pref) @@ -1478,20 +1478,20 @@ pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc ppr_pats kind pats - = sep [sep (map ppr pats), matchSeparator kind, ptext (sLit "...")] + = sep [sep (map ppr pats), matchSeparator kind, text "..."] ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat Id] -> SDoc ppr_eqn prefixF kind eqn = prefixF (ppr_pats kind (map unLoc eqn)) ppr_constraint :: (SDoc,[PmLit]) -> SDoc -ppr_constraint (var, lits) = var <+> ptext (sLit "is not one of") +ppr_constraint (var, lits) = var <+> text "is not one of" <+> braces (pprWithCommas ppr lits) ppr_uncovered :: ([PmExpr], [ComplexEq]) -> SDoc ppr_uncovered (expr_vec, complex) | null cs = fsep vec -- there are no literal constraints | otherwise = hang (fsep vec) 4 $ - ptext (sLit "where") <+> vcat (map ppr_constraint cs) + text "where" <+> vcat (map ppr_constraint cs) where sdoc_vec = mapM pprPmExprWithParens expr_vec (vec,cs) = runPmPprM sdoc_vec (filterComplex complex) diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 762883b4d1..ae8b6ab86d 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -13,6 +13,8 @@ import GHCi.RemoteTypes import Data.Array import ByteCodeTypes import GHC.Stack.CCS +import Foreign.C +import qualified Data.ByteString as B #endif import Type import HsSyn @@ -41,13 +43,11 @@ import CLabel import Util import Data.Time -import Foreign.C import System.Directory import Trace.Hpc.Mix import Trace.Hpc.Util -import qualified Data.ByteString as B import Data.Map (Map) import qualified Data.Map as Map @@ -1328,9 +1328,9 @@ hpcInitCode this_mod (HpcInfo tickCount hashNo) <> text "(void) __attribute__((constructor));" , text "static void hpc_init_" <> ppr this_mod <> text "(void)" , braces (vcat [ - ptext (sLit "extern StgWord64 ") <> tickboxes <> - ptext (sLit "[]") <> semi, - ptext (sLit "hs_hpc_module") <> + text "extern StgWord64 " <> tickboxes <> + text "[]" <> semi, + text "hs_hpc_module" <> parens (hcat (punctuate comma [ doubleQuotes full_name_str, int tickCount, -- really StgWord32 diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index da6085d2be..1c175f2cbd 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -598,22 +598,22 @@ warnRuleShadowing rule_name rule_act fn_id arg_ids | isLocalId lhs_id || canUnfold (idUnfolding lhs_id) -- If imported with no unfolding, no worries , idInlineActivation lhs_id `competesWith` rule_act - = warnDs (vcat [ hang (ptext (sLit "Rule") <+> pprRuleName rule_name - <+> ptext (sLit "may never fire")) - 2 (ptext (sLit "because") <+> quotes (ppr lhs_id) - <+> ptext (sLit "might inline first")) - , ptext (sLit "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for") + = warnDs (vcat [ hang (text "Rule" <+> pprRuleName rule_name + <+> text "may never fire") + 2 (text "because" <+> quotes (ppr lhs_id) + <+> text "might inline first") + , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for" <+> quotes (ppr lhs_id) , ifPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ]) | check_rules_too , bad_rule : _ <- get_bad_rules lhs_id - = warnDs (vcat [ hang (ptext (sLit "Rule") <+> pprRuleName rule_name - <+> ptext (sLit "may never fire")) - 2 (ptext (sLit "because rule") <+> pprRuleName (ruleName bad_rule) - <+> ptext (sLit "for")<+> quotes (ppr lhs_id) - <+> ptext (sLit "might fire first")) - , ptext (sLit "Probable fix: add phase [n] or [~n] to the competing rule") + = warnDs (vcat [ hang (text "Rule" <+> pprRuleName rule_name + <+> text "may never fire") + 2 (text "because rule" <+> pprRuleName (ruleName bad_rule) + <+> text "for"<+> quotes (ppr lhs_id) + <+> text "might fire first") + , text "Probable fix: add phase [n] or [~n] to the competing rule" , ifPprDebug (ppr bad_rule) ]) | otherwise diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index cc831d7c05..3691afb524 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -47,7 +47,6 @@ import Bag import VarSet import SrcLoc import ListSetOps( assocDefault ) -import FastString import Data.List data DsCmdEnv = DsCmdEnv { @@ -74,7 +73,7 @@ mkCmdEnv tc_meths find_meth prs std_name = assocDefault (mk_panic std_name) prs std_name - mk_panic std_name = pprPanic "mkCmdEnv" (ptext (sLit "Not found:") <+> ppr std_name) + mk_panic std_name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr std_name) -- arr :: forall b c. (b -> c) -> a b c do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 84f67e9f7c..4b500a327f 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -604,7 +604,7 @@ dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) | isJust (isClassOpId_maybe poly_id) = putSrcSpanDs loc $ - do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector") + do { warnDs (text "Ignoring useless SPECIALISE pragma for class method selector" <+> quotes (ppr poly_id)) ; return Nothing } -- There is no point in trying to specialise a class op -- Moreover, classops don't (currently) have an inl_sat arity set @@ -612,7 +612,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) | no_act_spec && isNeverActive rule_act = putSrcSpanDs loc $ - do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for NOINLINE function:") + do { warnDs (text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id)) ; return Nothing } -- Function is NOINLINE, and the specialiation inherits that -- See Note [Activation pragmas for SPECIALISE] @@ -626,9 +626,9 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) ; (bndrs, ds_lhs) <- liftM collectBinders (dsHsWrapper spec_co (Var poly_id)) ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs) - ; -- pprTrace "dsRule" (vcat [ ptext (sLit "Id:") <+> ppr poly_id - -- , ptext (sLit "spec_co:") <+> ppr spec_co - -- , ptext (sLit "ds_rhs:") <+> ppr ds_lhs ]) $ + ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id + -- , text "spec_co:" <+> ppr spec_co + -- , text "ds_rhs:" <+> ppr ds_lhs ]) $ case decomposeRuleLhs bndrs ds_lhs of { Left msg -> do { warnDs msg; return Nothing } ; Right (rule_bndrs, _fn, args) -> do @@ -652,7 +652,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) -- Commented out: see Note [SPECIALISE on INLINE functions] -- ; when (isInlinePragma id_inl) --- (warnDs $ ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:") +-- (warnDs $ text "SPECIALISE pragma on INLINE function probably won't fire:" -- <+> quotes (ppr poly_name)) ; return (Just (unitOL (spec_id, spec_rhs), rule)) @@ -705,7 +705,7 @@ dsMkUserRule this_mod is_local name act fn bndrs args rhs = do return rule ruleOrphWarn :: CoreRule -> SDoc -ruleOrphWarn rule = ptext (sLit "Orphan rule:") <+> ppr rule +ruleOrphWarn rule = text "Orphan rule:" <+> ppr rule {- Note [SPECIALISE on INLINE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -782,12 +782,12 @@ decomposeRuleLhs orig_bndrs orig_lhs | Just (fn_id, args) <- decompose fun2 args2 , let extra_dict_bndrs = mk_extra_dict_bndrs fn_id args - = -- pprTrace "decmposeRuleLhs" (vcat [ ptext (sLit "orig_bndrs:") <+> ppr orig_bndrs - -- , ptext (sLit "orig_lhs:") <+> ppr orig_lhs - -- , ptext (sLit "lhs1:") <+> ppr lhs1 - -- , ptext (sLit "extra_dict_bndrs:") <+> ppr extra_dict_bndrs - -- , ptext (sLit "fn_id:") <+> ppr fn_id - -- , ptext (sLit "args:") <+> ppr args]) $ + = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs + -- , text "orig_lhs:" <+> ppr orig_lhs + -- , text "lhs1:" <+> ppr lhs1 + -- , text "extra_dict_bndrs:" <+> ppr extra_dict_bndrs + -- , text "fn_id:" <+> ppr fn_id + -- , text "args:" <+> ppr args]) $ Right (orig_bndrs ++ extra_dict_bndrs, fn_id, args) | otherwise @@ -816,18 +816,18 @@ decomposeRuleLhs orig_bndrs orig_lhs decompose _ _ = Nothing - bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar")) + bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar") 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2 , text "Orig lhs:" <+> ppr orig_lhs]) - dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr - , ptext (sLit "is not bound in RULE lhs")]) + dead_msg bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr + , text "is not bound in RULE lhs"]) 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs , text "Orig lhs:" <+> ppr orig_lhs , text "optimised lhs:" <+> ppr lhs2 ]) pp_bndr bndr - | isTyVar bndr = ptext (sLit "type variable") <+> quotes (ppr bndr) - | Just pred <- evVarPred_maybe bndr = ptext (sLit "constraint") <+> quotes (ppr pred) - | otherwise = ptext (sLit "variable") <+> quotes (ppr bndr) + | isTyVar bndr = text "type variable" <+> quotes (ppr bndr) + | Just pred <- evVarPred_maybe bndr = text "constraint" <+> quotes (ppr pred) + | otherwise = text "variable" <+> quotes (ppr bndr) drop_dicts :: CoreExpr -> CoreExpr drop_dicts e diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 068218eb32..22a8707819 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -369,7 +369,7 @@ dsExpr (HsMultiIf res_ty alts) ; extractMatchResult match_result error_expr } where mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty - (ptext (sLit "multi-way if")) + (text "multi-way if") {- \noindent @@ -999,7 +999,7 @@ warnDiscardedDoBindings rhs rhs_ty -- Warn about discarding non-() things in 'monadic' binding ; if warn_unused && not (isUnitTy norm_elt_ty) then warnDs (badMonadBind rhs elt_ty - (ptext (sLit "-fno-warn-unused-do-bind"))) + (text "-fno-warn-unused-do-bind")) else -- Warn about discarding m a things in 'monadic' binding of the same type, @@ -1009,7 +1009,7 @@ warnDiscardedDoBindings rhs rhs_ty Just (elt_m_ty, _) | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty -> warnDs (badMonadBind rhs elt_ty - (ptext (sLit "-fno-warn-wrong-do-bind"))) + (text "-fno-warn-wrong-do-bind")) _ -> return () } } } | otherwise -- RHS does have type of form (m ty), which is weird @@ -1017,11 +1017,11 @@ warnDiscardedDoBindings rhs rhs_ty badMonadBind :: LHsExpr Id -> Type -> SDoc -> SDoc badMonadBind rhs elt_ty flag_doc - = vcat [ hang (ptext (sLit "A do-notation statement discarded a result of type")) + = vcat [ hang (text "A do-notation statement discarded a result of type") 2 (quotes (ppr elt_ty)) - , hang (ptext (sLit "Suppress this warning by saying")) - 2 (quotes $ ptext (sLit "_ <-") <+> ppr rhs) - , ptext (sLit "or by using the flag") <+> flag_doc ] + , hang (text "Suppress this warning by saying") + 2 (quotes $ text "_ <-" <+> ppr rhs) + , text "or by using the flag" <+> flag_doc ] {- ************************************************************************ diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index 2ee93731c3..0805ca096a 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -534,7 +534,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc arg_cname n stg_ty | libffi = char '*' <> parens (stg_ty <> char '*') <> - ptext (sLit "args") <> brackets (int (n-1)) + text "args" <> brackets (int (n-1)) | otherwise = text ('a':show n) -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled @@ -580,7 +580,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc -- Now we can cook up the prototype for the exported function. pprCconv = ccallConvAttribute cc - header_bits = ptext (sLit "extern") <+> fun_proto <> semi + header_bits = text "extern" <+> fun_proto <> semi fun_args | null aug_arg_info = text "void" @@ -589,8 +589,8 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc fun_proto | libffi - = ptext (sLit "void") <+> ftext c_nm <> - parens (ptext (sLit "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")) + = text "void" <+> ftext c_nm <> + parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr") | otherwise = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args @@ -633,14 +633,14 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc fun_proto $$ vcat [ lbrace - , ptext (sLit "Capability *cap;") + , text "Capability *cap;" , declareResult , declareCResult , text "cap = rts_lock();" -- create the application + perform it. - , ptext (sLit "rts_evalIO") <> parens ( + , text "rts_evalIO" <> parens ( char '&' <> cap <> - ptext (sLit "rts_apply") <> parens ( + text "rts_apply" <> parens ( cap <> text "(HaskellObj)" <> ptext (if is_IO_res_ty @@ -651,15 +651,15 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc ) <+> comma <> text "&ret" ) <> semi - , ptext (sLit "rts_checkSchedStatus") <> parens (doubleQuotes (ftext c_nm) + , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm) <> comma <> text "cap") <> semi , assignCResult - , ptext (sLit "rts_unlock(cap);") + , text "rts_unlock(cap);" , ppUnless res_hty_is_unit $ if libffi then char '*' <> parens (ffi_cResType <> char '*') <> - ptext (sLit "resp = cret;") - else ptext (sLit "return cret;") + text "resp = cret;" + else text "return cret;" , rbrace ] @@ -720,7 +720,7 @@ toCType = f False = f voidOK t' -- Otherwise we don't know the C type. If we are allowing -- void then return that; otherwise something has gone wrong. - | voidOK = (Nothing, ptext (sLit "void")) + | voidOK = (Nothing, text "void") | otherwise = pprPanic "toCType" (ppr t) diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index d835995857..f6c2b607d8 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -31,7 +31,6 @@ import Match import PrelNames import SrcLoc import Outputable -import FastString import TcType import ListSetOps( getNth ) import Util @@ -582,7 +581,7 @@ dePArrComp (LetStmt (L _ ds) : qs) pa cea = do let projBody = mkCoreLet (NonRec let'v clet) $ mkCoreTup [Var v, Var let'v] errTy = exprType projBody - errMsg = ptext (sLit "DsListComp.dePArrComp: internal error!") + errMsg = text "DsListComp.dePArrComp: internal error!" cerr <- mkErrorAppDs pAT_ERROR_ID errTy errMsg ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr let pa' = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)] @@ -648,7 +647,7 @@ mkLambda :: Type -- type of the argument -> DsM (CoreExpr, Type) mkLambda ty p ce = do v <- newSysLocalDs ty - let errMsg = ptext (sLit "DsListComp.deLambda: internal error!") + let errMsg = text "DsListComp.deLambda: internal error!" ce'ty = exprType ce cerr <- mkErrorAppDs pAT_ERROR_ID ce'ty errMsg res <- matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index acd32ba15b..ca427a4f3e 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -2271,5 +2271,5 @@ notHandledL loc what doc notHandled :: String -> SDoc -> DsM a notHandled what doc = failWithDs msg where - msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell")) + msg = hang (text what <+> text "not (yet) handled by Template Haskell") 2 doc diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index befad44933..92bfde0e5d 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -195,11 +195,11 @@ initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside _ -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err } } - paErr = ptext (sLit "To use ParallelArrays,") <+> specBackend $$ hint1 $$ hint2 - veErr = ptext (sLit "To use -fvectorise,") <+> specBackend $$ hint1 $$ hint2 - specBackend = ptext (sLit "you must specify a DPH backend package") - hint1 = ptext (sLit "Look for packages named 'dph-lifted-*' with 'ghc-pkg'") - hint2 = ptext (sLit "You may need to install them with 'cabal install dph-examples'") + paErr = text "To use ParallelArrays," <+> specBackend $$ hint1 $$ hint2 + veErr = text "To use -fvectorise," <+> specBackend $$ hint1 $$ hint2 + specBackend = text "you must specify a DPH backend package" + hint1 = text "Look for packages named 'dph-lifted-*' with 'ghc-pkg'" + hint2 = text "You may need to install them with 'cabal install dph-examples'" initDPHBuiltins thing_inside = do { -- If '-XParallelArrays' given, we populate the builtin table for desugaring those @@ -261,7 +261,7 @@ mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv -> (DsGblEnv, DsLclEnv) mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var = let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) } - if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod) + if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod) real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1) gbl_env = DsGblEnv { ds_mod = mod , ds_fam_inst_env = fam_inst_env diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs index 301d3a69e2..2fab8750af 100644 --- a/compiler/deSugar/MatchLit.hs +++ b/compiler/deSugar/MatchLit.hs @@ -139,9 +139,9 @@ warnAboutIdentities dflags (Var conv_fn) type_of_conv , idName conv_fn `elem` conversionNames , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv , arg_ty `eqType` res_ty -- So we are converting ty -> ty - = warnDs (vcat [ ptext (sLit "Call of") <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv - , nest 2 $ ptext (sLit "can probably be omitted") - , parens (ptext (sLit "Use -fno-warn-identities to suppress this message")) + = warnDs (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv + , nest 2 $ text "can probably be omitted" + , parens (text "Use -fno-warn-identities to suppress this message") ]) warnAboutIdentities _ _ _ = return () @@ -173,9 +173,9 @@ warnAboutOverflowedLiterals dflags lit check :: forall a. (Bounded a, Integral a) => Integer -> Name -> a -> DsM () check i tc _proxy = when (i < minB || i > maxB) $ do - warnDs (vcat [ ptext (sLit "Literal") <+> integer i - <+> ptext (sLit "is out of the") <+> ppr tc <+> ptext (sLit "range") - <+> integer minB <> ptext (sLit "..") <> integer maxB + warnDs (vcat [ text "Literal" <+> integer i + <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range") + <+> integer minB <> text ".." <> integer maxB , sug ]) where minB = toInteger (minBound :: a) @@ -183,7 +183,7 @@ warnAboutOverflowedLiterals dflags lit sug | minB == -i -- Note [Suggest NegativeLiterals] , i > 0 , not (xopt LangExt.NegativeLiterals dflags) - = ptext (sLit "If you are trying to write a large negative literal, use NegativeLiterals") + = text "If you are trying to write a large negative literal, use NegativeLiterals" | otherwise = Outputable.empty {- @@ -209,7 +209,7 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr , let check :: forall a. (Enum a, Num a) => a -> DsM () check _proxy = when (null enumeration) $ - warnDs (ptext (sLit "Enumeration is empty")) + warnDs (text "Enumeration is empty") where enumeration :: [a] enumeration = case mThn of diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs index 4ca9461a5d..3c5fe280fa 100644 --- a/compiler/deSugar/PmExpr.hs +++ b/compiler/deSugar/PmExpr.hs @@ -22,7 +22,6 @@ import TysWiredIn import Outputable import Util import SrcLoc -import FastString -- sLit import VarSet import Data.Maybe (mapMaybe) @@ -332,8 +331,8 @@ filterComplex = zipWith rename nameList . map mkGroup -- Try nice names p,q,r,s,t before using the (ugly) t_i nameList :: [SDoc] - nameList = map (ptext . sLit) ["p","q","r","s","t"] ++ - [ ptext (sLit ('t':show u)) | u <- [(0 :: Int)..] ] + nameList = map text ["p","q","r","s","t"] ++ + [ text ('t':show u) | u <- [(0 :: Int)..] ] -- ---------------------------------------------------------------------------- |