summaryrefslogtreecommitdiff
path: root/compiler/deSugar
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/deSugar')
-rw-r--r--compiler/deSugar/Check.hs34
-rw-r--r--compiler/deSugar/Coverage.hs10
-rw-r--r--compiler/deSugar/Desugar.hs22
-rw-r--r--compiler/deSugar/DsArrows.hs3
-rw-r--r--compiler/deSugar/DsBinds.hs38
-rw-r--r--compiler/deSugar/DsExpr.hs14
-rw-r--r--compiler/deSugar/DsForeign.hs24
-rw-r--r--compiler/deSugar/DsListComp.hs5
-rw-r--r--compiler/deSugar/DsMeta.hs2
-rw-r--r--compiler/deSugar/DsMonad.hs12
-rw-r--r--compiler/deSugar/MatchLit.hs16
-rw-r--r--compiler/deSugar/PmExpr.hs5
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)..] ]
-- ----------------------------------------------------------------------------
View Lorry Controller Status