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 | |
| 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')
165 files changed, 2887 insertions, 2930 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index 5db992de51..54534d2e74 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -192,8 +192,8 @@ bestOneShot OneShotLam _ = OneShotLam pprOneShotInfo :: OneShotInfo -> SDoc pprOneShotInfo NoOneShotInfo = empty -pprOneShotInfo ProbOneShot = ptext (sLit "ProbOneShot") -pprOneShotInfo OneShotLam = ptext (sLit "OneShot") +pprOneShotInfo ProbOneShot = text "ProbOneShot" +pprOneShotInfo OneShotLam = text "OneShot" instance Outputable OneShotInfo where ppr = pprOneShotInfo @@ -211,8 +211,8 @@ data SwapFlag | IsSwapped -- Args are: expected, actual instance Outputable SwapFlag where - ppr IsSwapped = ptext (sLit "Is-swapped") - ppr NotSwapped = ptext (sLit "Not-swapped") + ppr IsSwapped = text "Is-swapped" + ppr NotSwapped = text "Not-swapped" flipSwap :: SwapFlag -> SwapFlag flipSwap IsSwapped = NotSwapped @@ -327,9 +327,9 @@ data FixityDirection = InfixL | InfixR | InfixN deriving (Eq, Data, Typeable) instance Outputable FixityDirection where - ppr InfixL = ptext (sLit "infixl") - ppr InfixR = ptext (sLit "infixr") - ppr InfixN = ptext (sLit "infix") + ppr InfixL = text "infixl" + ppr InfixR = text "infixr" + ppr InfixN = text "infix" ------------------------ maxPrecedence, minPrecedence :: Int @@ -391,8 +391,8 @@ isTopLevel TopLevel = True isTopLevel NotTopLevel = False instance Outputable TopLevelFlag where - ppr TopLevel = ptext (sLit "<TopLevel>") - ppr NotTopLevel = ptext (sLit "<NotTopLevel>") + ppr TopLevel = text "<TopLevel>" + ppr NotTopLevel = text "<NotTopLevel>" {- ************************************************************************ @@ -440,8 +440,8 @@ boolToRecFlag True = Recursive boolToRecFlag False = NonRecursive instance Outputable RecFlag where - ppr Recursive = ptext (sLit "Recursive") - ppr NonRecursive = ptext (sLit "NonRecursive") + ppr Recursive = text "Recursive" + ppr NonRecursive = text "NonRecursive" {- ************************************************************************ @@ -460,8 +460,8 @@ isGenerated Generated = True isGenerated FromSource = False instance Outputable Origin where - ppr FromSource = ptext (sLit "FromSource") - ppr Generated = ptext (sLit "Generated") + ppr FromSource = text "FromSource" + ppr Generated = text "Generated" {- ************************************************************************ @@ -570,13 +570,13 @@ instance Outputable OverlapFlag where instance Outputable OverlapMode where ppr (NoOverlap _) = empty - ppr (Overlappable _) = ptext (sLit "[overlappable]") - ppr (Overlapping _) = ptext (sLit "[overlapping]") - ppr (Overlaps _) = ptext (sLit "[overlap ok]") - ppr (Incoherent _) = ptext (sLit "[incoherent]") + ppr (Overlappable _) = text "[overlappable]" + ppr (Overlapping _) = text "[overlapping]" + ppr (Overlaps _) = text "[overlap ok]" + ppr (Incoherent _) = text "[incoherent]" pprSafeOverlap :: Bool -> SDoc -pprSafeOverlap True = ptext $ sLit "[safe]" +pprSafeOverlap True = text "[safe]" pprSafeOverlap False = empty {- @@ -604,9 +604,9 @@ boxityTupleSort Unboxed = UnboxedTuple tupleParens :: TupleSort -> SDoc -> SDoc tupleParens BoxedTuple p = parens p -tupleParens UnboxedTuple p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") +tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)") tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %) - | opt_PprStyle_Debug = ptext (sLit "(%") <+> p <+> ptext (sLit "%)") + | opt_PprStyle_Debug = text "(%" <+> p <+> ptext (sLit "%)") | otherwise = parens p {- @@ -746,10 +746,10 @@ zapFragileOcc occ = occ instance Outputable OccInfo where -- only used for debugging; never parsed. KSW 1999-07 ppr NoOccInfo = empty - ppr (IAmALoopBreaker ro) = ptext (sLit "LoopBreaker") <> if ro then char '!' else empty - ppr IAmDead = ptext (sLit "Dead") + ppr (IAmALoopBreaker ro) = text "LoopBreaker" <> if ro then char '!' else empty + ppr IAmDead = text "Dead" ppr (OneOcc inside_lam one_branch int_cxt) - = ptext (sLit "Once") <> pp_lam <> pp_br <> pp_args + = text "Once" <> pp_lam <> pp_br <> pp_args where pp_lam | inside_lam = char 'L' | otherwise = empty @@ -776,8 +776,8 @@ data DefMethSpec ty | GenericDM ty -- Default method given with code of this type instance Outputable (DefMethSpec ty) where - ppr VanillaDM = ptext (sLit "{- Has default method -}") - ppr (GenericDM {}) = ptext (sLit "{- Has generic default method -}") + ppr VanillaDM = text "{- Has default method -}" + ppr (GenericDM {}) = text "{- Has generic default method -}" {- ************************************************************************ @@ -790,8 +790,8 @@ instance Outputable (DefMethSpec ty) where data SuccessFlag = Succeeded | Failed instance Outputable SuccessFlag where - ppr Succeeded = ptext (sLit "Succeeded") - ppr Failed = ptext (sLit "Failed") + ppr Succeeded = text "Succeeded" + ppr Failed = text "Failed" successIf :: Bool -> SuccessFlag successIf True = Succeeded @@ -888,7 +888,7 @@ data CompilerPhase instance Outputable CompilerPhase where ppr (Phase n) = int n - ppr InitialPhase = ptext (sLit "InitialPhase") + ppr InitialPhase = text "InitialPhase" -- See note [Pragma source text] data Activation = NeverActive @@ -1056,19 +1056,19 @@ setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } instance Outputable Activation where - ppr AlwaysActive = brackets (ptext (sLit "ALWAYS")) - ppr NeverActive = brackets (ptext (sLit "NEVER")) + ppr AlwaysActive = brackets (text "ALWAYS") + ppr NeverActive = brackets (text "NEVER") ppr (ActiveBefore _ n) = brackets (char '~' <> int n) ppr (ActiveAfter _ n) = brackets (int n) instance Outputable RuleMatchInfo where - ppr ConLike = ptext (sLit "CONLIKE") - ppr FunLike = ptext (sLit "FUNLIKE") + ppr ConLike = text "CONLIKE" + ppr FunLike = text "FUNLIKE" instance Outputable InlineSpec where - ppr Inline = ptext (sLit "INLINE") - ppr NoInline = ptext (sLit "NOINLINE") - ppr Inlinable = ptext (sLit "INLINABLE") + ppr Inline = text "INLINE" + ppr NoInline = text "NOINLINE" + ppr Inlinable = text "INLINABLE" ppr EmptyInlineSpec = empty instance Outputable InlinePragma where @@ -1080,7 +1080,7 @@ instance Outputable InlinePragma where pp_act NoInline NeverActive = empty pp_act _ act = ppr act - pp_sat | Just ar <- mb_arity = parens (ptext (sLit "sat-args=") <> int ar) + pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar) | otherwise = empty pp_info | isFunLike info = empty | otherwise = ppr info diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 466e3c1604..8bf91d0bb8 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -630,10 +630,10 @@ instance Outputable HsSrcBang where ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark instance Outputable HsImplBang where - ppr HsLazy = ptext (sLit "Lazy") - ppr (HsUnpack Nothing) = ptext (sLit "Unpacked") - ppr (HsUnpack (Just co)) = ptext (sLit "Unpacked") <> parens (ppr co) - ppr HsStrict = ptext (sLit "StrictNotUnpacked") + ppr HsLazy = text "Lazy" + ppr (HsUnpack Nothing) = text "Unpacked" + ppr (HsUnpack (Just co)) = text "Unpacked" <> parens (ppr co) + ppr HsStrict = text "StrictNotUnpacked" instance Outputable SrcStrictness where ppr SrcLazy = char '~' @@ -641,12 +641,12 @@ instance Outputable SrcStrictness where ppr NoSrcStrict = empty instance Outputable SrcUnpackedness where - ppr SrcUnpack = ptext (sLit "{-# UNPACK #-}") - ppr SrcNoUnpack = ptext (sLit "{-# NOUNPACK #-}") + ppr SrcUnpack = text "{-# UNPACK #-}" + ppr SrcNoUnpack = text "{-# NOUNPACK #-}" ppr NoSrcUnpack = empty instance Outputable StrictnessMark where - ppr MarkedStrict = ptext (sLit "!") + ppr MarkedStrict = text "!" ppr NotMarkedStrict = empty instance Binary SrcStrictness where @@ -1042,7 +1042,7 @@ dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs}) inst_tys = ASSERT2( length univ_tvs == length inst_tys - , ptext (sLit "dataConInstArgTys") <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) + , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) ASSERT2( null ex_tvs, ppr dc ) map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc) @@ -1059,7 +1059,7 @@ dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs}) inst_tys = ASSERT2( length tyvars == length inst_tys - , ptext (sLit "dataConInstOrigArgTys") <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) + , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) map (substTyWith tyvars inst_tys) arg_tys where tyvars = univ_tvs ++ ex_tvs diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs index 1a6d1d1fb4..65b8b2b9ee 100644 --- a/compiler/basicTypes/Demand.hs +++ b/compiler/basicTypes/Demand.hs @@ -72,7 +72,6 @@ import Maybes ( orElse ) import Type ( Type, isUnLiftedType ) import TyCon ( isNewTyCon, isClassTyCon ) import DataCon ( splitDataProductType_maybe ) -import FastString {- ************************************************************************ @@ -787,8 +786,8 @@ data TypeShape = TsFun TypeShape | TsUnk instance Outputable TypeShape where - ppr TsUnk = ptext (sLit "TsUnk") - ppr (TsFun ts) = ptext (sLit "TsFun") <> parens (ppr ts) + ppr TsUnk = text "TsUnk" + ppr (TsFun ts) = text "TsFun" <> parens (ppr ts) ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss) trimToType :: Demand -> TypeShape -> Demand diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs index 64703f59f4..3bc1da0ef4 100644 --- a/compiler/basicTypes/IdInfo.hs +++ b/compiler/basicTypes/IdInfo.hs @@ -81,7 +81,6 @@ import {-# SOURCE #-} PatSyn import ForeignCall import Outputable import Module -import FastString import Demand -- infixl so you can say (id `set` a `set` b) @@ -166,17 +165,17 @@ pprIdDetails VanillaId = empty pprIdDetails other = brackets (pp other) where pp VanillaId = panic "pprIdDetails" - pp (DataConWorkId _) = ptext (sLit "DataCon") - pp (DataConWrapId _) = ptext (sLit "DataConWrapper") - pp (ClassOpId {}) = ptext (sLit "ClassOp") - pp (PrimOpId _) = ptext (sLit "PrimOp") - pp (FCallId _) = ptext (sLit "ForeignCall") - pp (TickBoxOpId _) = ptext (sLit "TickBoxOp") - pp (DFunId nt) = ptext (sLit "DFunId") <> ppWhen nt (ptext (sLit "(nt)")) + pp (DataConWorkId _) = text "DataCon" + pp (DataConWrapId _) = text "DataConWrapper" + pp (ClassOpId {}) = text "ClassOp" + pp (PrimOpId _) = text "PrimOp" + pp (FCallId _) = text "ForeignCall" + pp (TickBoxOpId _) = text "TickBoxOp" + pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)") pp (RecSelId { sel_naughty = is_naughty }) - = brackets $ ptext (sLit "RecSel") - <> ppWhen is_naughty (ptext (sLit "(naughty)")) - pp CoVarId = ptext (sLit "CoVarId") + = brackets $ text "RecSel" + <> ppWhen is_naughty (text "(naughty)") + pp CoVarId = text "CoVarId" {- ************************************************************************ @@ -303,7 +302,7 @@ unknownArity = 0 :: Arity ppArityInfo :: Int -> SDoc ppArityInfo 0 = empty -ppArityInfo n = hsep [ptext (sLit "Arity"), int n] +ppArityInfo n = hsep [text "Arity", int n] {- ************************************************************************ @@ -427,7 +426,7 @@ instance Outputable CafInfo where ppr = ppCafInfo ppCafInfo :: CafInfo -> SDoc -ppCafInfo NoCafRefs = ptext (sLit "NoCafRefs") +ppCafInfo NoCafRefs = text "NoCafRefs" ppCafInfo MayHaveCafRefs = empty {- @@ -493,4 +492,4 @@ data TickBoxOp = TickBox Module {-# UNPACK #-} !TickBoxId instance Outputable TickBoxOp where - ppr (TickBox mod n) = ptext (sLit "tick") <+> ppr (mod,n) + ppr (TickBox mod n) = text "tick" <+> ppr (mod,n) diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs index f1a99f7980..18b441244c 100644 --- a/compiler/basicTypes/Literal.hs +++ b/compiler/basicTypes/Literal.hs @@ -446,7 +446,7 @@ litTag (LitInteger {}) = 11 pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc pprLiteral _ (MachChar c) = pprPrimChar c pprLiteral _ (MachStr s) = pprHsBytes s -pprLiteral _ (MachNullAddr) = ptext (sLit "__NULL") +pprLiteral _ (MachNullAddr) = text "__NULL" pprLiteral _ (MachInt i) = pprPrimInt i pprLiteral _ (MachInt64 i) = pprPrimInt64 i pprLiteral _ (MachWord w) = pprPrimWord w @@ -454,7 +454,7 @@ pprLiteral _ (MachWord64 w) = pprPrimWord64 w pprLiteral _ (MachFloat f) = float (fromRat f) <> primFloatSuffix pprLiteral _ (MachDouble d) = double (fromRat d) <> primDoubleSuffix pprLiteral add_par (LitInteger i _) = pprIntegerVal add_par i -pprLiteral add_par (MachLabel l mb fod) = add_par (ptext (sLit "__label") <+> b <+> ppr fod) +pprLiteral add_par (MachLabel l mb fod) = add_par (text "__label" <+> b <+> ppr fod) where b = case mb of Nothing -> pprHsString l Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs index 769b5aa044..74eec8aa14 100644 --- a/compiler/basicTypes/Name.hs +++ b/compiler/basicTypes/Name.hs @@ -514,7 +514,7 @@ pprExternal sty uniq mod occ is_wired is_builtin -- ToDo: maybe we could print all wired-in things unqualified -- in code style, to reduce symbol table bloat? | debugStyle sty = pp_mod <> ppr_occ_name occ - <> braces (hsep [if is_wired then ptext (sLit "(w)") else empty, + <> braces (hsep [if is_wired then text "(w)" else empty, pprNameSpaceBrief (occNameSpace occ), pprUnique uniq]) | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax @@ -583,7 +583,7 @@ ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ)) -- Prints (if mod information is available) "Defined at <loc>" or -- "Defined in <mod>" information for a Name. pprDefinedAt :: Name -> SDoc -pprDefinedAt name = ptext (sLit "Defined") <+> pprNameDefnLoc name +pprDefinedAt name = text "Defined" <+> pprNameDefnLoc name pprNameDefnLoc :: Name -> SDoc -- Prints "at <loc>" or @@ -593,12 +593,12 @@ pprNameDefnLoc name -- nameSrcLoc rather than nameSrcSpan -- It seems less cluttered to show a location -- rather than a span for the definition point - RealSrcLoc s -> ptext (sLit "at") <+> ppr s + RealSrcLoc s -> text "at" <+> ppr s UnhelpfulLoc s | isInternalName name || isSystemName name - -> ptext (sLit "at") <+> ftext s + -> text "at" <+> ftext s | otherwise - -> ptext (sLit "in") <+> quotes (ppr (nameModule name)) + -> text "in" <+> quotes (ppr (nameModule name)) -- | Get a string representation of a 'Name' that's unique and stable diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs index 40614add32..f7020a95f4 100644 --- a/compiler/basicTypes/OccName.hs +++ b/compiler/basicTypes/OccName.hs @@ -191,10 +191,10 @@ isValNameSpace VarName = True isValNameSpace _ = False pprNameSpace :: NameSpace -> SDoc -pprNameSpace DataName = ptext (sLit "data constructor") -pprNameSpace VarName = ptext (sLit "variable") -pprNameSpace TvName = ptext (sLit "type variable") -pprNameSpace TcClsName = ptext (sLit "type constructor or class") +pprNameSpace DataName = text "data constructor" +pprNameSpace VarName = text "variable" +pprNameSpace TvName = text "type variable" +pprNameSpace TcClsName = text "type constructor or class" pprNonVarNameSpace :: NameSpace -> SDoc pprNonVarNameSpace VarName = empty @@ -203,8 +203,8 @@ pprNonVarNameSpace ns = pprNameSpace ns pprNameSpaceBrief :: NameSpace -> SDoc pprNameSpaceBrief DataName = char 'd' pprNameSpaceBrief VarName = char 'v' -pprNameSpaceBrief TvName = ptext (sLit "tv") -pprNameSpaceBrief TcClsName = ptext (sLit "tc") +pprNameSpaceBrief TvName = text "tv" +pprNameSpaceBrief TcClsName = text "tc" -- demoteNameSpace lowers the NameSpace if possible. We can not know -- in advance, since a TvName can appear in an HsTyVar. diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs index d948a2b89e..a0430ca319 100644 --- a/compiler/basicTypes/PatSyn.hs +++ b/compiler/basicTypes/PatSyn.hs @@ -31,7 +31,6 @@ import Outputable import Unique import Util import BasicTypes -import FastString import Var import FieldLabel @@ -386,7 +385,7 @@ patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs , psExTyVars = ex_tvs, psArgs = arg_tys }) inst_tys = ASSERT2( length tyvars == length inst_tys - , ptext (sLit "patSynInstArgTys") <+> ppr name $$ ppr tyvars $$ ppr inst_tys ) + , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys ) map (substTyWith tyvars inst_tys) arg_tys where tyvars = univ_tvs ++ ex_tvs @@ -401,5 +400,5 @@ patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs , psOrigResTy = res_ty }) inst_tys = ASSERT2( length univ_tvs == length inst_tys - , ptext (sLit "patSynInstResTy") <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys ) + , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys ) substTyWith univ_tvs inst_tys res_ty diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs index ce697064ad..6e0350da74 100644 --- a/compiler/basicTypes/RdrName.hs +++ b/compiler/basicTypes/RdrName.hs @@ -330,9 +330,9 @@ data LocalRdrEnv = LRE { lre_env :: OccEnv Name instance Outputable LocalRdrEnv where ppr (LRE {lre_env = env, lre_in_scope = ns}) - = hang (ptext (sLit "LocalRdrEnv {")) - 2 (vcat [ ptext (sLit "env =") <+> pprOccEnv ppr_elt env - , ptext (sLit "in_scope =") + = hang (text "LocalRdrEnv {") + 2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env + , text "in_scope =" <+> braces (pprWithCommas ppr (nameSetElems ns)) ] <+> char '}') where @@ -437,10 +437,10 @@ data Parent = NoParent instance Outputable Parent where ppr NoParent = empty - ppr (ParentIs n) = ptext (sLit "parent:") <> ppr n - ppr (FldParent n f) = ptext (sLit "fldparent:") + ppr (ParentIs n) = text "parent:" <> ppr n + ppr (FldParent n f) = text "fldparent:" <> ppr n <> colon <> ppr f - ppr (PatternSynonym) = ptext (sLit "pattern synonym") + ppr (PatternSynonym) = text "pattern synonym" plusParent :: Parent -> Parent -> Parent -- See Note [Combining parents] @@ -678,7 +678,7 @@ instance Outputable GlobalRdrElt where pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc pprGlobalRdrEnv locals_only env - = vcat [ ptext (sLit "GlobalRdrEnv") <+> ppWhen locals_only (ptext (sLit "(locals only)")) + = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (ptext (sLit "(locals only)")) <+> lbrace , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ] <+> rbrace) ] @@ -687,7 +687,7 @@ pprGlobalRdrEnv locals_only env | otherwise = gres pp [] = empty pp gres = hang (ppr occ - <+> parens (ptext (sLit "unique") <+> ppr (getUnique occ)) + <+> parens (text "unique" <+> ppr (getUnique occ)) <> colon) 2 (vcat (map ppr gres)) where @@ -1094,7 +1094,7 @@ pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) | otherwise = head pp_provs where pp_provs = pp_lcl ++ map pp_is iss - pp_lcl = if lcl then [ptext (sLit "defined at") <+> ppr (nameSrcLoc name)] + pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] else [] pp_is is = sep [ppr is, ppr_defn_site is name] @@ -1105,25 +1105,25 @@ ppr_defn_site imp_spec name | same_module && not (isGoodSrcSpan loc) = empty -- Nothing interesting to say | otherwise - = parens $ hang (ptext (sLit "and originally defined") <+> pp_mod) + = parens $ hang (text "and originally defined" <+> pp_mod) 2 (pprLoc loc) where loc = nameSrcSpan name defining_mod = nameModule name same_module = importSpecModule imp_spec == moduleName defining_mod pp_mod | same_module = empty - | otherwise = ptext (sLit "in") <+> quotes (ppr defining_mod) + | otherwise = text "in" <+> quotes (ppr defining_mod) instance Outputable ImportSpec where ppr imp_spec - = ptext (sLit "imported") <+> qual - <+> ptext (sLit "from") <+> quotes (ppr (importSpecModule imp_spec)) + = text "imported" <+> qual + <+> text "from" <+> quotes (ppr (importSpecModule imp_spec)) <+> pprLoc (importSpecLoc imp_spec) where - qual | is_qual (is_decl imp_spec) = ptext (sLit "qualified") + qual | is_qual (is_decl imp_spec) = text "qualified" | otherwise = empty pprLoc :: SrcSpan -> SDoc -pprLoc (RealSrcSpan s) = ptext (sLit "at") <+> ppr s +pprLoc (RealSrcSpan s) = text "at" <+> ppr s pprLoc (UnhelpfulSpan {}) = empty diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs index f57111fc40..11a4dee340 100644 --- a/compiler/basicTypes/Var.hs +++ b/compiler/basicTypes/Var.hs @@ -78,7 +78,6 @@ import Name hiding (varName) import Unique import Util import DynFlags -import FastString import Outputable import Data.Data @@ -236,7 +235,7 @@ instance Outputable Var where ppr_debug :: Var -> PprStyle -> SDoc ppr_debug (TyVar {}) sty - | debugStyle sty = brackets (ptext (sLit "tv")) + | debugStyle sty = brackets (text "tv") ppr_debug (TcTyVar {tc_tv_details = d}) sty | dumpStyle sty || debugStyle sty = brackets (pprTcTyVarDetails d) ppr_debug (Id { idScope = s, id_details = d }) sty @@ -244,9 +243,9 @@ ppr_debug (Id { idScope = s, id_details = d }) sty ppr_debug _ _ = empty ppr_id_scope :: IdScope -> SDoc -ppr_id_scope GlobalId = ptext (sLit "gid") -ppr_id_scope (LocalId Exported) = ptext (sLit "lidx") -ppr_id_scope (LocalId NotExported) = ptext (sLit "lid") +ppr_id_scope GlobalId = text "gid" +ppr_id_scope (LocalId Exported) = text "lidx" +ppr_id_scope (LocalId NotExported) = text "lid" instance NamedThing Var where getName = varName diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs index 08c7965893..0fa0f57616 100644 --- a/compiler/basicTypes/VarEnv.hs +++ b/compiler/basicTypes/VarEnv.hs @@ -69,7 +69,6 @@ import Util import Maybes import Outputable import StaticFlags -import FastString {- ************************************************************************ @@ -99,7 +98,7 @@ data InScopeSet = InScope (VarEnv Var) {-# UNPACK #-} !Int -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway instance Outputable InScopeSet where - ppr (InScope s _) = ptext (sLit "InScope") <+> ppr s + ppr (InScope s _) = text "InScope" <+> ppr s emptyInScopeSet :: InScopeSet emptyInScopeSet = InScope emptyVarSet 1 diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index a7eb797eeb..9304d66323 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -1000,11 +1000,11 @@ pprCLabel platform (DynamicLinkerLabel info lbl) pprCLabel _ PicBaseLabel | cGhcWithNativeCodeGen == "YES" - = ptext (sLit "1b") + = text "1b" pprCLabel platform (DeadStripPreventer lbl) | cGhcWithNativeCodeGen == "YES" - = pprCLabel platform lbl <> ptext (sLit "_dsp") + = pprCLabel platform lbl <> text "_dsp" pprCLabel platform lbl = getPprStyle $ \ sty -> @@ -1028,22 +1028,22 @@ pprAsmCLbl _ lbl pprCLbl :: CLabel -> SDoc pprCLbl (StringLitLabel u) - = pprUnique u <> ptext (sLit "_str") + = pprUnique u <> text "_str" pprCLbl (CaseLabel u CaseReturnPt) - = hcat [pprUnique u, ptext (sLit "_ret")] + = hcat [pprUnique u, text "_ret"] pprCLbl (CaseLabel u CaseReturnInfo) - = hcat [pprUnique u, ptext (sLit "_info")] + = hcat [pprUnique u, text "_info"] pprCLbl (CaseLabel u (CaseAlt tag)) - = hcat [pprUnique u, pp_cSEP, int tag, ptext (sLit "_alt")] + = hcat [pprUnique u, pp_cSEP, int tag, text "_alt"] pprCLbl (CaseLabel u CaseDefault) - = hcat [pprUnique u, ptext (sLit "_dflt")] + = hcat [pprUnique u, text "_dflt"] pprCLbl (SRTLabel u) - = pprUnique u <> pp_cSEP <> ptext (sLit "srt") + = pprUnique u <> pp_cSEP <> text "srt" -pprCLbl (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> ptext (sLit "srtd") -pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLit "btm") +pprCLbl (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> text "srtd" +pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> text "btm" -- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7') -- until that gets resolved we'll just force them to start -- with a letter so the label will be legal assmbly code. @@ -1053,56 +1053,56 @@ pprCLbl (CmmLabel _ str CmmCode) = ftext str pprCLbl (CmmLabel _ str CmmData) = ftext str pprCLbl (CmmLabel _ str CmmPrimCall) = ftext str -pprCLbl (RtsLabel (RtsApFast str)) = ftext str <> ptext (sLit "_fast") +pprCLbl (RtsLabel (RtsApFast str)) = ftext str <> text "_fast" pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset)) - = hcat [ptext (sLit "stg_sel_"), text (show offset), + = hcat [text "stg_sel_", text (show offset), ptext (if upd_reqd then (sLit "_upd_info") else (sLit "_noupd_info")) ] pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset)) - = hcat [ptext (sLit "stg_sel_"), text (show offset), + = hcat [text "stg_sel_", text (show offset), ptext (if upd_reqd then (sLit "_upd_entry") else (sLit "_noupd_entry")) ] pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity)) - = hcat [ptext (sLit "stg_ap_"), text (show arity), + = hcat [text "stg_ap_", text (show arity), ptext (if upd_reqd then (sLit "_upd_info") else (sLit "_noupd_info")) ] pprCLbl (RtsLabel (RtsApEntry upd_reqd arity)) - = hcat [ptext (sLit "stg_ap_"), text (show arity), + = hcat [text "stg_ap_", text (show arity), ptext (if upd_reqd then (sLit "_upd_entry") else (sLit "_noupd_entry")) ] pprCLbl (CmmLabel _ fs CmmInfo) - = ftext fs <> ptext (sLit "_info") + = ftext fs <> text "_info" pprCLbl (CmmLabel _ fs CmmEntry) - = ftext fs <> ptext (sLit "_entry") + = ftext fs <> text "_entry" pprCLbl (CmmLabel _ fs CmmRetInfo) - = ftext fs <> ptext (sLit "_info") + = ftext fs <> text "_info" pprCLbl (CmmLabel _ fs CmmRet) - = ftext fs <> ptext (sLit "_ret") + = ftext fs <> text "_ret" pprCLbl (CmmLabel _ fs CmmClosure) - = ftext fs <> ptext (sLit "_closure") + = ftext fs <> text "_closure" pprCLbl (RtsLabel (RtsPrimOp primop)) - = ptext (sLit "stg_") <> ppr primop + = text "stg_" <> ppr primop pprCLbl (RtsLabel (RtsSlowFastTickyCtr pat)) - = ptext (sLit "SLOW_CALL_fast_") <> text pat <> ptext (sLit "_ctr") + = text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr") pprCLbl (ForeignLabel str _ _ _) = ftext str @@ -1113,10 +1113,10 @@ pprCLbl (CC_Label cc) = ppr cc pprCLbl (CCS_Label ccs) = ppr ccs pprCLbl (PlainModuleInitLabel mod) - = ptext (sLit "__stginit_") <> ppr mod + = text "__stginit_" <> ppr mod pprCLbl (HpcTicksLabel mod) - = ptext (sLit "_hpc_tickboxes_") <> ppr mod <> ptext (sLit "_hpc") + = text "_hpc_tickboxes_" <> ppr mod <> ptext (sLit "_hpc") pprCLbl (AsmTempLabel {}) = panic "pprCLbl AsmTempLabel" pprCLbl (AsmTempDerivedLabel {})= panic "pprCLbl AsmTempDerivedLabel" @@ -1127,19 +1127,19 @@ pprCLbl (DeadStripPreventer {}) = panic "pprCLbl DeadStripPreventer" ppIdFlavor :: IdLabelInfo -> SDoc ppIdFlavor x = pp_cSEP <> (case x of - Closure -> ptext (sLit "closure") - SRT -> ptext (sLit "srt") - InfoTable -> ptext (sLit "info") - LocalInfoTable -> ptext (sLit "info") - Entry -> ptext (sLit "entry") - LocalEntry -> ptext (sLit "entry") - Slow -> ptext (sLit "slow") - RednCounts -> ptext (sLit "ct") - ConEntry -> ptext (sLit "con_entry") - ConInfoTable -> ptext (sLit "con_info") - StaticConEntry -> ptext (sLit "static_entry") - StaticInfoTable -> ptext (sLit "static_info") - ClosureTable -> ptext (sLit "closure_tbl") + Closure -> text "closure" + SRT -> text "srt" + InfoTable -> text "info" + LocalInfoTable -> text "info" + Entry -> text "entry" + LocalEntry -> text "entry" + Slow -> text "slow" + RednCounts -> text "ct" + ConEntry -> text "con_entry" + ConInfoTable -> text "con_info" + StaticConEntry -> text "static_entry" + StaticInfoTable -> text "static_info" + ClosureTable -> text "closure_tbl" ) diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index 1a10e683e1..5fea0e71ac 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -1071,8 +1071,8 @@ data StackSlot = Occupied | Empty -- Occupied: a return address or part of an update frame instance Outputable StackSlot where - ppr Occupied = ptext (sLit "XXX") - ppr Empty = ptext (sLit "---") + ppr Occupied = text "XXX" + ppr Empty = text "---" dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot] dropEmpty 0 ss = Just ss diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 015337bdad..c009112d4b 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -17,7 +17,6 @@ import CmmLive import CmmSwitch (switchTargetsToList) import PprCmm () import BlockId -import FastString import Outputable import DynFlags @@ -41,9 +40,9 @@ cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc runCmmLint dflags l p = case unCL (l p) dflags of - Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), + Left err -> Just (vcat [text "Cmm lint error:", nest 2 err, - ptext $ sLit ("Program was:"), + text "Program was:", nest 2 (ppr p)]) Right _ -> Nothing diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs index f852d54b34..ae46330f7c 100644 --- a/compiler/cmm/CmmType.hs +++ b/compiler/cmm/CmmType.hs @@ -63,9 +63,9 @@ instance Outputable CmmType where ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid) instance Outputable CmmCat where - ppr FloatCat = ptext $ sLit("F") - ppr GcPtrCat = ptext $ sLit("P") - ppr BitsCat = ptext $ sLit("I") + ppr FloatCat = text "F" + ppr GcPtrCat = text "P" + ppr BitsCat = text "I" ppr (VecCat n cat) = ppr cat <> text "x" <> ppr n <> text "V" -- Why is CmmType stratified? For native code generation, diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 3d3acec47d..e679d5516b 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -66,7 +66,7 @@ pprCs dflags cmms = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms) where split_marker - | gopt Opt_SplitObjs dflags = ptext (sLit "__STG_SPLIT_MARKER") + | gopt Opt_SplitObjs dflags = text "__STG_SPLIT_MARKER" | otherwise = empty writeCs :: DynFlags -> Handle -> [RawCmmGroup] -> IO () @@ -112,13 +112,13 @@ pprTop (CmmProc infos clbl _ graph) = pprTop (CmmData _section (Statics lbl [CmmString str])) = hcat [ - pprLocalness lbl, ptext (sLit "char "), ppr lbl, - ptext (sLit "[] = "), pprStringInCStyle str, semi + pprLocalness lbl, text "char ", ppr lbl, + text "[] = ", pprStringInCStyle str, semi ] pprTop (CmmData _section (Statics lbl [CmmUninitialised size])) = hcat [ - pprLocalness lbl, ptext (sLit "char "), ppr lbl, + pprLocalness lbl, text "char ", ppr lbl, brackets (int size), semi ] @@ -147,16 +147,16 @@ pprBBlock block = pprWordArray :: CLabel -> [CmmStatic] -> SDoc pprWordArray lbl ds = sdocWithDynFlags $ \dflags -> - hcat [ pprLocalness lbl, ptext (sLit "StgWord") - , space, ppr lbl, ptext (sLit "[] = {") ] + hcat [ pprLocalness lbl, text "StgWord" + , space, ppr lbl, text "[] = {" ] $$ nest 8 (commafy (pprStatics dflags ds)) - $$ ptext (sLit "};") + $$ text "};" -- -- has to be static, if it isn't globally visible -- pprLocalness :: CLabel -> SDoc -pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ") +pprLocalness lbl | not $ externallyVisibleCLabel lbl = text "static " | otherwise = empty -- -------------------------------------------------------------------------- @@ -169,7 +169,7 @@ pprStmt stmt = sdocWithDynFlags $ \dflags -> case stmt of CmmEntry{} -> empty - CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/") + CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/") -- XXX if the string contains "*/", we need to fix it -- XXX we probably want to emit these comments when -- some debugging option is on. They can get quite @@ -182,7 +182,7 @@ pprStmt stmt = CmmStore dest src | typeWidth rep == W64 && wordWidth dflags /= W64 - -> (if isFloatType rep then ptext (sLit "ASSIGN_DBL") + -> (if isFloatType rep then text "ASSIGN_DBL" else ptext (sLit ("ASSIGN_Word64"))) <> parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi @@ -240,7 +240,7 @@ pprStmt stmt = -- We also need to cast mem primops to prevent conflicts with GCC -- builtins (see bug #5967). | Just _align <- machOpMemcpyishAlign op - = (ptext (sLit ";EF_(") <> fn <> char ')' <> semi) $$ + = (text ";EF_(" <> fn <> char ')' <> semi) $$ pprForeignCall fn cconv hresults hargs | otherwise = pprCall fn cconv hresults hargs @@ -269,7 +269,7 @@ pprForeignCall fn cconv results args = fn_call pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc pprCFunType ppr_fn cconv ress args = sdocWithDynFlags $ \dflags -> - let res_type [] = ptext (sLit "void") + let res_type [] = text "void" res_type [(one, hint)] = machRepHintCType (localRegType one) hint res_type _ = panic "pprCFunType: only void or 1 return value supported" @@ -281,16 +281,16 @@ pprCFunType ppr_fn cconv ress args -- --------------------------------------------------------------------- -- unconditional branches pprBranch :: BlockId -> SDoc -pprBranch ident = ptext (sLit "goto") <+> pprBlockId ident <> semi +pprBranch ident = text "goto" <+> pprBlockId ident <> semi -- --------------------------------------------------------------------- -- conditional branches to local labels pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc pprCondBranch expr yes no - = hsep [ ptext (sLit "if") , parens(pprExpr expr) , - ptext (sLit "goto"), pprBlockId yes <> semi, - ptext (sLit "else goto"), pprBlockId no <> semi ] + = hsep [ text "if" , parens(pprExpr expr) , + text "goto", pprBlockId yes <> semi, + text "else goto", pprBlockId no <> semi ] -- --------------------------------------------------------------------- -- a local table branch @@ -299,7 +299,7 @@ pprCondBranch expr yes no -- pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc pprSwitch dflags e ids - = (hang (ptext (sLit "switch") <+> parens ( pprExpr e ) <+> lbrace) + = (hang (text "switch" <+> parens ( pprExpr e ) <+> lbrace) 4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace where (pairs, mbdef) = switchTargetsFallThrough ids @@ -308,16 +308,16 @@ pprSwitch dflags e ids caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix where do_fallthrough ix = - hsep [ ptext (sLit "case") , pprHexVal ix (wordWidth dflags) <> colon , - ptext (sLit "/* fall through */") ] + hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon , + text "/* fall through */" ] final_branch ix = - hsep [ ptext (sLit "case") , pprHexVal ix (wordWidth dflags) <> colon , - ptext (sLit "goto") , (pprBlockId ident) <> semi ] + hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon , + text "goto" , (pprBlockId ident) <> semi ] caseify (_ , _ ) = panic "pprSwitch: switch with no cases!" - def | Just l <- mbdef = ptext (sLit "default: goto") <+> pprBlockId l <> semi + def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi | otherwise = empty -- --------------------------------------------------------------------- @@ -360,8 +360,8 @@ pprExpr e = case e of pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc pprLoad dflags e ty | width == W64, wordWidth dflags /= W64 - = (if isFloatType ty then ptext (sLit "PK_DBL") - else ptext (sLit "PK_Word64")) + = (if isFloatType ty then text "PK_DBL" + else text "PK_Word64") <> parens (mkP_ <> pprExpr1 e) | otherwise @@ -394,7 +394,7 @@ pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc pprMachOpApp op args | isMulMayOfloOp op - = ptext (sLit "mulIntMayOflo") <> parens (commafy (map pprExpr args)) + = text "mulIntMayOflo" <> parens (commafy (map pprExpr args)) where isMulMayOfloOp (MO_U_MulMayOflo _) = True isMulMayOfloOp (MO_S_MulMayOflo _) = True isMulMayOfloOp _ = False @@ -446,9 +446,9 @@ pprLit lit = case lit of CmmFloat f w -> parens (machRep_F_CType w) <> str where d = fromRational f :: Double - str | isInfinite d && d < 0 = ptext (sLit "-INFINITY") - | isInfinite d = ptext (sLit "INFINITY") - | isNaN d = ptext (sLit "NAN") + str | isInfinite d && d < 0 = text "-INFINITY" + | isInfinite d = text "INFINITY" + | isNaN d = text "NAN" | otherwise = text (show d) -- these constants come from <math.h> -- see #1861 @@ -489,7 +489,7 @@ pprStatics dflags (CmmStaticLit (CmmFloat f W32) : rest) = pprPanic "pprStatics: float" (vcat (map ppr' rest)) where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags -> ppr (cmmLitType dflags l) - ppr' _other = ptext (sLit "bad static!") + ppr' _other = text "bad static!" pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest) = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest) @@ -536,8 +536,8 @@ pprMachOp_for_C mop = case mop of -- Integer operations MO_Add _ -> char '+' MO_Sub _ -> char '-' - MO_Eq _ -> ptext (sLit "==") - MO_Ne _ -> ptext (sLit "!=") + MO_Eq _ -> text "==" + MO_Ne _ -> text "!=" MO_Mul _ -> char '*' MO_S_Quot _ -> char '/' @@ -555,22 +555,22 @@ pprMachOp_for_C mop = case mop of MO_F_Quot _ -> char '/' -- Signed comparisons - MO_S_Ge _ -> ptext (sLit ">=") - MO_S_Le _ -> ptext (sLit "<=") + MO_S_Ge _ -> text ">=" + MO_S_Le _ -> text "<=" MO_S_Gt _ -> char '>' MO_S_Lt _ -> char '<' -- & Unsigned comparisons - MO_U_Ge _ -> ptext (sLit ">=") - MO_U_Le _ -> ptext (sLit "<=") + MO_U_Ge _ -> text ">=" + MO_U_Le _ -> text "<=" MO_U_Gt _ -> char '>' MO_U_Lt _ -> char '<' -- & Floating-point comparisons - MO_F_Eq _ -> ptext (sLit "==") - MO_F_Ne _ -> ptext (sLit "!=") - MO_F_Ge _ -> ptext (sLit ">=") - MO_F_Le _ -> ptext (sLit "<=") + MO_F_Eq _ -> text "==" + MO_F_Ne _ -> text "!=" + MO_F_Ge _ -> text ">=" + MO_F_Le _ -> text "<=" MO_F_Gt _ -> char '>' MO_F_Lt _ -> char '<' @@ -580,9 +580,9 @@ pprMachOp_for_C mop = case mop of MO_Or _ -> char '|' MO_Xor _ -> char '^' MO_Not _ -> char '~' - MO_Shl _ -> ptext (sLit "<<") - MO_U_Shr _ -> ptext (sLit ">>") -- unsigned shift right - MO_S_Shr _ -> ptext (sLit ">>") -- signed shift right + MO_Shl _ -> text "<<" + MO_U_Shr _ -> text ">>" -- unsigned shift right + MO_S_Shr _ -> text ">>" -- signed shift right -- Conversions. Some of these will be NOPs, but never those that convert -- between ints and floats. @@ -604,85 +604,85 @@ pprMachOp_for_C mop = case mop of MO_FS_Conv _from to -> parens (machRep_S_CType to) MO_S_MulMayOflo _ -> pprTrace "offending mop:" - (ptext $ sLit "MO_S_MulMayOflo") + (text "MO_S_MulMayOflo") (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo" ++ " should have been handled earlier!") MO_U_MulMayOflo _ -> pprTrace "offending mop:" - (ptext $ sLit "MO_U_MulMayOflo") + (text "MO_U_MulMayOflo") (panic $ "PprC.pprMachOp_for_C: MO_U_MulMayOflo" ++ " should have been handled earlier!") MO_V_Insert {} -> pprTrace "offending mop:" - (ptext $ sLit "MO_V_Insert") + (text "MO_V_Insert") (panic $ "PprC.pprMachOp_for_C: MO_V_Insert" ++ " should have been handled earlier!") MO_V_Extract {} -> pprTrace "offending mop:" - (ptext $ sLit "MO_V_Extract") + (text "MO_V_Extract") (panic $ "PprC.pprMachOp_for_C: MO_V_Extract" ++ " should have been handled earlier!") MO_V_Add {} -> pprTrace "offending mop:" - (ptext $ sLit "MO_V_Add") + (text "MO_V_Add") (panic $ "PprC.pprMachOp_for_C: MO_V_Add" ++ " should have been handled earlier!") MO_V_Sub {} -> pprTrace "offending mop:" - (ptext $ sLit "MO_V_Sub") + (text "MO_V_Sub") (panic $ "PprC.pprMachOp_for_C: MO_V_Sub" ++ " should have been handled earlier!") MO_V_Mul {} -> pprTrace "offending mop:" - (ptext $ sLit "MO_V_Mul") + (text "MO_V_Mul") (panic $ "PprC.pprMachOp_for_C: MO_V_Mul" ++ " should have been handled earlier!") MO_VS_Quot {} -> pprTrace "offending mop:" - (ptext $ sLit "MO_VS_Quot") + (text "MO_VS_Quot") (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot" ++ " should have been handled earlier!") MO_VS_Rem {} -> pprTrace "offending mop:" - (ptext $ sLit "MO_VS_Rem") + (text "MO_VS_Rem") (panic $ "PprC.pprMachOp_for_C: MO_VS_Rem" ++ " should have been handled earlier!") MO_VS_Neg {} -> pprTrace "offending mop:" - (ptext $ sLit "MO_VS_Neg") + (text "MO_VS_Neg") (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg" ++ " should have been handled earlier!") MO_VU_Quot {} -> pprTrace "offending mop:" - (ptext $ sLit "MO_VU_Quot") + (text "MO_VU_Quot") (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot" ++ " should have been handled earlier!") MO_VU_Rem {} -> pprTrace "offending mop:" - (ptext $ sLit "MO_VU_Rem") + (text "MO_VU_Rem") (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem" ++ " should have been handled earlier!") MO_VF_Insert {} -> pprTrace "offending mop:" - (ptext $ sLit "MO_VF_Insert") + (text "MO_VF_Insert") (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert" ++ " should have been handled earlier!") MO_VF_Extract {} -> pprTrace "offending mop:" - (ptext $ sLit "MO_VF_Extract") + (text "MO_VF_Extract") (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract" ++ " should have been handled earlier!") MO_VF_Add {} -> pprTrace "offending mop:" - (ptext $ sLit "MO_VF_Add") + (text "MO_VF_Add") (panic $ "PprC.pprMachOp_for_C: MO_VF_Add" ++ " should have been handled earlier!") MO_VF_Sub {} -> pprTrace "offending mop:" - (ptext $ sLit "MO_VF_Sub") + (text "MO_VF_Sub") (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub" ++ " should have been handled earlier!") MO_VF_Neg {} -> pprTrace "offending mop:" - (ptext $ sLit "MO_VF_Neg") + (text "MO_VF_Neg") (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg" ++ " should have been handled earlier!") MO_VF_Mul {} -> pprTrace "offending mop:" - (ptext $ sLit "MO_VF_Mul") + (text "MO_VF_Mul") (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul" ++ " should have been handled earlier!") MO_VF_Quot {} -> pprTrace "offending mop:" - (ptext $ sLit "MO_VF_Quot") + (text "MO_VF_Quot") (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot" ++ " should have been handled earlier!") @@ -715,36 +715,36 @@ pprCallishMachOp_for_C :: CallishMachOp -> SDoc pprCallishMachOp_for_C mop = case mop of - MO_F64_Pwr -> ptext (sLit "pow") - MO_F64_Sin -> ptext (sLit "sin") - MO_F64_Cos -> ptext (sLit "cos") - MO_F64_Tan -> ptext (sLit "tan") - MO_F64_Sinh -> ptext (sLit "sinh") - MO_F64_Cosh -> ptext (sLit "cosh") - MO_F64_Tanh -> ptext (sLit "tanh") - MO_F64_Asin -> ptext (sLit "asin") - MO_F64_Acos -> ptext (sLit "acos") - MO_F64_Atan -> ptext (sLit "atan") - MO_F64_Log -> ptext (sLit "log") - MO_F64_Exp -> ptext (sLit "exp") - MO_F64_Sqrt -> ptext (sLit "sqrt") - MO_F32_Pwr -> ptext (sLit "powf") - MO_F32_Sin -> ptext (sLit "sinf") - MO_F32_Cos -> ptext (sLit "cosf") - MO_F32_Tan -> ptext (sLit "tanf") - MO_F32_Sinh -> ptext (sLit "sinhf") - MO_F32_Cosh -> ptext (sLit "coshf") - MO_F32_Tanh -> ptext (sLit "tanhf") - MO_F32_Asin -> ptext (sLit "asinf") - MO_F32_Acos -> ptext (sLit "acosf") - MO_F32_Atan -> ptext (sLit "atanf") - MO_F32_Log -> ptext (sLit "logf") - MO_F32_Exp -> ptext (sLit "expf") - MO_F32_Sqrt -> ptext (sLit "sqrtf") - MO_WriteBarrier -> ptext (sLit "write_barrier") - MO_Memcpy _ -> ptext (sLit "memcpy") - MO_Memset _ -> ptext (sLit "memset") - MO_Memmove _ -> ptext (sLit "memmove") + MO_F64_Pwr -> text "pow" + MO_F64_Sin -> text "sin" + MO_F64_Cos -> text "cos" + MO_F64_Tan -> text "tan" + MO_F64_Sinh -> text "sinh" + MO_F64_Cosh -> text "cosh" + MO_F64_Tanh -> text "tanh" + MO_F64_Asin -> text "asin" + MO_F64_Acos -> text "acos" + MO_F64_Atan -> text "atan" + MO_F64_Log -> text "log" + MO_F64_Exp -> text "exp" + MO_F64_Sqrt -> text "sqrt" + MO_F32_Pwr -> text "powf" + MO_F32_Sin -> text "sinf" + MO_F32_Cos -> text "cosf" + MO_F32_Tan -> text "tanf" + MO_F32_Sinh -> text "sinhf" + MO_F32_Cosh -> text "coshf" + MO_F32_Tanh -> text "tanhf" + MO_F32_Asin -> text "asinf" + MO_F32_Acos -> text "acosf" + MO_F32_Atan -> text "atanf" + MO_F32_Log -> text "logf" + MO_F32_Exp -> text "expf" + MO_F32_Sqrt -> text "sqrtf" + MO_WriteBarrier -> text "write_barrier" + MO_Memcpy _ -> text "memcpy" + MO_Memset _ -> text "memset" + MO_Memmove _ -> text "memmove" (MO_BSwap w) -> ptext (sLit $ bSwapLabel w) (MO_PopCnt w) -> ptext (sLit $ popCntLabel w) (MO_Clz w) -> ptext (sLit $ clzLabel w) @@ -776,17 +776,17 @@ pprCallishMachOp_for_C mop mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc -mkJMP_ i = ptext (sLit "JMP_") <> parens i -mkFN_ i = ptext (sLit "FN_") <> parens i -- externally visible function -mkIF_ i = ptext (sLit "IF_") <> parens i -- locally visible +mkJMP_ i = text "JMP_" <> parens i +mkFN_ i = text "FN_" <> parens i -- externally visible function +mkIF_ i = text "IF_" <> parens i -- locally visible -- from includes/Stg.h -- mkC_,mkW_,mkP_ :: SDoc -mkC_ = ptext (sLit "(C_)") -- StgChar -mkW_ = ptext (sLit "(W_)") -- StgWord -mkP_ = ptext (sLit "(P_)") -- StgWord* +mkC_ = text "(C_)" -- StgChar +mkW_ = text "(W_)" -- StgWord +mkP_ = text "(P_)" -- StgWord* -- --------------------------------------------------------------------- -- @@ -819,8 +819,8 @@ pprAssign _ r1 r2 | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2) | otherwise = mkAssign (pprExpr r2) where mkAssign x = if r1 == CmmGlobal BaseReg - then ptext (sLit "ASSIGN_BaseReg") <> parens x <> semi - else pprReg r1 <> ptext (sLit " = ") <> x <> semi + then text "ASSIGN_BaseReg" <> parens x <> semi + else pprReg r1 <> text " = " <> x <> semi -- --------------------------------------------------------------------- -- Registers @@ -869,10 +869,10 @@ isStrangeTypeGlobal BaseReg = True isStrangeTypeGlobal r = isFixedPtrGlobalReg r strangeRegType :: CmmReg -> Maybe SDoc -strangeRegType (CmmGlobal CCCS) = Just (ptext (sLit "struct CostCentreStack_ *")) -strangeRegType (CmmGlobal CurrentTSO) = Just (ptext (sLit "struct StgTSO_ *")) -strangeRegType (CmmGlobal CurrentNursery) = Just (ptext (sLit "struct bdescr_ *")) -strangeRegType (CmmGlobal BaseReg) = Just (ptext (sLit "struct StgRegTable_ *")) +strangeRegType (CmmGlobal CCCS) = Just (text "struct CostCentreStack_ *") +strangeRegType (CmmGlobal CurrentTSO) = Just (text "struct StgTSO_ *") +strangeRegType (CmmGlobal CurrentNursery) = Just (text "struct bdescr_ *") +strangeRegType (CmmGlobal BaseReg) = Just (text "struct StgRegTable_ *") strangeRegType _ = Nothing -- pprReg just prints the register name. @@ -884,30 +884,30 @@ pprReg r = case r of pprAsPtrReg :: CmmReg -> SDoc pprAsPtrReg (CmmGlobal (VanillaReg n gcp)) - = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> ptext (sLit ".p") + = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> text ".p" pprAsPtrReg other_reg = pprReg other_reg pprGlobalReg :: GlobalReg -> SDoc pprGlobalReg gr = case gr of - VanillaReg n _ -> char 'R' <> int n <> ptext (sLit ".w") + VanillaReg n _ -> char 'R' <> int n <> text ".w" -- pprGlobalReg prints a VanillaReg as a .w regardless -- Example: R1.w = R1.w & (-0x8UL); -- JMP_(*R1.p); FloatReg n -> char 'F' <> int n DoubleReg n -> char 'D' <> int n LongReg n -> char 'L' <> int n - Sp -> ptext (sLit "Sp") - SpLim -> ptext (sLit "SpLim") - Hp -> ptext (sLit "Hp") - HpLim -> ptext (sLit "HpLim") - CCCS -> ptext (sLit "CCCS") - CurrentTSO -> ptext (sLit "CurrentTSO") - CurrentNursery -> ptext (sLit "CurrentNursery") - HpAlloc -> ptext (sLit "HpAlloc") - BaseReg -> ptext (sLit "BaseReg") - EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info") - GCEnter1 -> ptext (sLit "stg_gc_enter_1") - GCFun -> ptext (sLit "stg_gc_fun") + Sp -> text "Sp" + SpLim -> text "SpLim" + Hp -> text "Hp" + HpLim -> text "HpLim" + CCCS -> text "CCCS" + CurrentTSO -> text "CurrentTSO" + CurrentNursery -> text "CurrentNursery" + HpAlloc -> text "HpAlloc" + BaseReg -> text "BaseReg" + EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info" + GCEnter1 -> text "stg_gc_enter_1" + GCFun -> text "stg_gc_fun" other -> panic $ "pprGlobalReg: Unsupported register: " ++ show other pprLocalReg :: LocalReg -> SDoc @@ -927,12 +927,12 @@ pprCall ppr_fn cconv results args where ppr_assign [] rhs = rhs ppr_assign [(one,hint)] rhs - = pprLocalReg one <> ptext (sLit " = ") + = pprLocalReg one <> text " = " <> pprUnHint hint (localRegType one) <> rhs ppr_assign _other _rhs = panic "pprCall: multiple results" pprArg (expr, AddrHint) - = cCast (ptext (sLit "void *")) expr + = cCast (text "void *") expr -- see comment by machRepHintCType below pprArg (expr, SignedHint) = sdocWithDynFlags $ \dflags -> @@ -981,8 +981,8 @@ pprExternDecl _in_srt lbl hcat [ visibility, label_type lbl, lparen, ppr lbl, text ");" ] where - label_type lbl | isCFunctionLabel lbl = ptext (sLit "F_") - | otherwise = ptext (sLit "I_") + label_type lbl | isCFunctionLabel lbl = text "F_" + | otherwise = text "I_" visibility | externallyVisibleCLabel lbl = char 'E' @@ -992,7 +992,7 @@ pprExternDecl _in_srt lbl -- we must generate an appropriate prototype for it, so that the C compiler will -- add the @n suffix to the label (#2276) stdcall_decl sz = sdocWithDynFlags $ \dflags -> - ptext (sLit "extern __attribute__((stdcall)) void ") <> ppr lbl + text "extern __attribute__((stdcall)) void " <> ppr lbl <> parens (commafy (replicate (sz `quot` wORD_SIZE dflags) (machRep_U_CType (wordWidth dflags)))) <> semi @@ -1071,11 +1071,11 @@ cLoad :: CmmExpr -> CmmType -> SDoc cLoad expr rep = sdocWithPlatform $ \platform -> if bewareLoadStoreAlignment (platformArch platform) - then let decl = machRepCType rep <+> ptext (sLit "x") <> semi - struct = ptext (sLit "struct") <+> braces (decl) - packed_attr = ptext (sLit "__attribute__((packed))") + then let decl = machRepCType rep <+> text "x" <> semi + struct = text "struct" <+> braces (decl) + packed_attr = text "__attribute__((packed))" cast = parens (struct <+> packed_attr <> char '*') - in parens (cast <+> pprExpr1 expr) <> ptext (sLit "->x") + in parens (cast <+> pprExpr1 expr) <> text "->x" else char '*' <> parens (cCast (machRepPtrCType rep) expr) where -- On these platforms, unaligned loads are known to cause problems bewareLoadStoreAlignment ArchAlpha = True @@ -1097,14 +1097,14 @@ isCmmWordType dflags ty = not (isFloatType ty) -- argument, we always cast the argument to (void *), to avoid warnings from -- the C compiler. machRepHintCType :: CmmType -> ForeignHint -> SDoc -machRepHintCType _ AddrHint = ptext (sLit "void *") +machRepHintCType _ AddrHint = text "void *" machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep) machRepHintCType rep _other = machRepCType rep machRepPtrCType :: CmmType -> SDoc machRepPtrCType r = sdocWithDynFlags $ \dflags -> - if isCmmWordType dflags r then ptext (sLit "P_") + if isCmmWordType dflags r then text "P_" else machRepCType r <> char '*' machRepCType :: CmmType -> SDoc @@ -1114,30 +1114,30 @@ machRepCType ty | isFloatType ty = machRep_F_CType w w = typeWidth ty machRep_F_CType :: Width -> SDoc -machRep_F_CType W32 = ptext (sLit "StgFloat") -- ToDo: correct? -machRep_F_CType W64 = ptext (sLit "StgDouble") +machRep_F_CType W32 = text "StgFloat" -- ToDo: correct? +machRep_F_CType W64 = text "StgDouble" machRep_F_CType _ = panic "machRep_F_CType" machRep_U_CType :: Width -> SDoc machRep_U_CType w = sdocWithDynFlags $ \dflags -> case w of - _ | w == wordWidth dflags -> ptext (sLit "W_") - W8 -> ptext (sLit "StgWord8") - W16 -> ptext (sLit "StgWord16") - W32 -> ptext (sLit "StgWord32") - W64 -> ptext (sLit "StgWord64") + _ | w == wordWidth dflags -> text "W_" + W8 -> text "StgWord8" + W16 -> text "StgWord16" + W32 -> text "StgWord32" + W64 -> text "StgWord64" _ -> panic "machRep_U_CType" machRep_S_CType :: Width -> SDoc machRep_S_CType w = sdocWithDynFlags $ \dflags -> case w of - _ | w == wordWidth dflags -> ptext (sLit "I_") - W8 -> ptext (sLit "StgInt8") - W16 -> ptext (sLit "StgInt16") - W32 -> ptext (sLit "StgInt32") - W64 -> ptext (sLit "StgInt64") + _ | w == wordWidth dflags -> text "I_" + W8 -> text "StgInt8" + W16 -> text "StgInt16" + W32 -> text "StgInt32" + W64 -> text "StgInt64" _ -> panic "machRep_S_CType" @@ -1213,8 +1213,8 @@ commafy xs = hsep $ punctuate comma xs pprHexVal :: Integer -> Width -> SDoc pprHexVal w rep | w < 0 = parens (char '-' <> - ptext (sLit "0x") <> intToDoc (-w) <> repsuffix rep) - | otherwise = ptext (sLit "0x") <> intToDoc w <> repsuffix rep + text "0x" <> intToDoc (-w) <> repsuffix rep) + | otherwise = text "0x" <> intToDoc w <> repsuffix rep where -- type suffix for literals: -- Integer literals are unsigned in Cmm/C. We explicitly cast to @@ -1224,8 +1224,8 @@ pprHexVal w rep repsuffix W64 = sdocWithDynFlags $ \dflags -> if cINT_SIZE dflags == 8 then char 'U' - else if cLONG_SIZE dflags == 8 then ptext (sLit "UL") - else if cLONG_LONG_SIZE dflags == 8 then ptext (sLit "ULL") + else if cLONG_SIZE dflags == 8 then text "UL" + else if cLONG_LONG_SIZE dflags == 8 then text "ULL" else panic "pprHexVal: Can't find a 64-bit type" repsuffix _ = char 'U' diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 5caea90db4..9517ea3c09 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -102,13 +102,13 @@ instance Outputable CmmGraph where pprStackInfo :: CmmStackInfo -> SDoc pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) = - ptext (sLit "arg_space: ") <> ppr arg_space <+> - ptext (sLit "updfr_space: ") <> ppr updfr_space + text "arg_space: " <> ppr arg_space <+> + text "updfr_space: " <> ppr updfr_space pprTopInfo :: CmmTopInfo -> SDoc pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) = - vcat [ptext (sLit "info_tbl: ") <> ppr info_tbl, - ptext (sLit "stack_info: ") <> ppr stack_info] + vcat [text "info_tbl: " <> ppr info_tbl, + text "stack_info: " <> ppr stack_info] ---------------------------------------------------------- -- Outputting blocks and graphs @@ -161,7 +161,7 @@ pprForeignConvention (ForeignConvention c args res ret) = pprReturnInfo :: CmmReturnInfo -> SDoc pprReturnInfo CmmMayReturn = empty -pprReturnInfo CmmNeverReturns = ptext (sLit "never returns") +pprReturnInfo CmmNeverReturns = text "never returns" pprForeignTarget :: ForeignTarget -> SDoc pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn @@ -193,11 +193,11 @@ pprNode node = pp_node <+> pp_debug -- //tick bla<...> CmmTick t -> if gopt Opt_PprShowTicks dflags - then ptext (sLit "//tick") <+> ppr t + then text "//tick" <+> ppr t else empty -- unwind reg = expr; - CmmUnwind r e -> ptext (sLit "unwind ") <> ppr r <+> char '=' <+> ppr e + CmmUnwind r e -> text "unwind " <> ppr r <+> char '=' <+> ppr e -- reg = expr; CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi @@ -213,75 +213,75 @@ pprNode node = pp_node <+> pp_debug CmmUnsafeForeignCall target results args -> hsep [ ppUnless (null results) $ parens (commafy $ map ppr results) <+> equals, - ptext $ sLit "call", + text "call", ppr target <> parens (commafy $ map ppr args) <> semi] -- goto label; - CmmBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi + CmmBranch ident -> text "goto" <+> ppr ident <> semi -- if (expr) goto t; else goto f; CmmCondBranch expr t f l -> - hsep [ ptext (sLit "if") + hsep [ text "if" , parens(ppr expr) , case l of Nothing -> empty - Just b -> parens (ptext (sLit "likely:") <+> ppr b) - , ptext (sLit "goto") + Just b -> parens (text "likely:" <+> ppr b) + , text "goto" , ppr t <> semi - , ptext (sLit "else goto") + , text "else goto" , ppr f <> semi ] CmmSwitch expr ids -> - hang (hsep [ ptext (sLit "switch") + hang (hsep [ text "switch" , range , if isTrivialCmmExpr expr then ppr expr else parens (ppr expr) - , ptext (sLit "{") + , text "{" ]) 4 (vcat (map ppCase cases) $$ def) $$ rbrace where (cases, mbdef) = switchTargetsFallThrough ids ppCase (is,l) = hsep - [ ptext (sLit "case") + [ text "case" , commafy $ map integer is - , ptext (sLit ": goto") + , text ": goto" , ppr l <> semi ] def | Just l <- mbdef = hsep - [ ptext (sLit "default: goto") + [ text "default: goto" , ppr l <> semi ] | otherwise = empty - range = brackets $ hsep [integer lo, ptext (sLit ".."), integer hi] + range = brackets $ hsep [integer lo, text "..", integer hi] where (lo,hi) = switchTargetsRange ids CmmCall tgt k regs out res updfr_off -> - hcat [ ptext (sLit "call"), space + hcat [ text "call", space , pprFun tgt, parens (interpp'SP regs), space , returns <+> - ptext (sLit "args: ") <> ppr out <> comma <+> - ptext (sLit "res: ") <> ppr res <> comma <+> - ptext (sLit "upd: ") <> ppr updfr_off + text "args: " <> ppr out <> comma <+> + text "res: " <> ppr res <> comma <+> + text "upd: " <> ppr updfr_off , semi ] where pprFun f@(CmmLit _) = ppr f pprFun f = parens (ppr f) returns - | Just r <- k = ptext (sLit "returns to") <+> ppr r <> comma + | Just r <- k = text "returns to" <+> ppr r <> comma | otherwise = empty CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} -> - hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++ - [ ptext (sLit "foreign call"), space - , ppr t, ptext (sLit "(...)"), space - , ptext (sLit "returns to") <+> ppr s - <+> ptext (sLit "args:") <+> parens (ppr as) - <+> ptext (sLit "ress:") <+> parens (ppr rs) - , ptext (sLit "ret_args:") <+> ppr a - , ptext (sLit "ret_off:") <+> ppr u + hcat $ if i then [text "interruptible", space] else [] ++ + [ text "foreign call", space + , ppr t, text "(...)", space + , text "returns to" <+> ppr s + <+> text "args:" <+> parens (ppr as) + <+> text "ress:" <+> parens (ppr rs) + , text "ret_args:" <+> ppr a + , text "ret_off:" <+> ppr u , semi ] pp_debug :: SDoc diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs index 830f536891..9364d2bcf4 100644 --- a/compiler/cmm/PprCmmDecl.hs +++ b/compiler/cmm/PprCmmDecl.hs @@ -59,7 +59,7 @@ pprCmms :: (Outputable info, Outputable g) => [GenCmmGroup CmmStatics info g] -> SDoc pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) where - separator = space $$ ptext (sLit "-------------------") $$ space + separator = space $$ text "-------------------" $$ space writeCmms :: (Outputable info, Outputable g) => DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO () @@ -96,7 +96,7 @@ pprTop :: (Outputable d, Outputable info, Outputable i) pprTop (CmmProc info lbl live graph) - = vcat [ ppr lbl <> lparen <> rparen <+> ptext (sLit "// ") <+> ppr live + = vcat [ ppr lbl <> lparen <> rparen <+> text "// " <+> ppr live , nest 8 $ lbrace <+> ppr info $$ rbrace , nest 4 $ ppr graph , rbrace ] @@ -117,15 +117,15 @@ pprInfoTable :: CmmInfoTable -> SDoc pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep , cit_prof = prof_info , cit_srt = _srt }) - = vcat [ ptext (sLit "label:") <+> ppr lbl - , ptext (sLit "rep:") <> ppr rep + = vcat [ text "label:" <+> ppr lbl + , text "rep:" <> ppr rep , case prof_info of NoProfilingInfo -> empty - ProfilingInfo ct cd -> vcat [ ptext (sLit "type:") <+> pprWord8String ct - , ptext (sLit "desc: ") <> pprWord8String cd ] ] + ProfilingInfo ct cd -> vcat [ text "type:" <+> pprWord8String ct + , text "desc: " <> pprWord8String cd ] ] instance Outputable C_SRT where - ppr NoC_SRT = ptext (sLit "_no_srt_") + ppr NoC_SRT = text "_no_srt_" ppr (C_SRT label off bitmap) = parens (ppr label <> comma <> ppr off <> comma <> ppr bitmap) @@ -146,7 +146,7 @@ pprStatics (Statics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds) pprStatic :: CmmStatic -> SDoc pprStatic s = case s of - CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi + CmmStaticLit lit -> nest 4 $ text "const" <+> pprLit lit <> semi CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) CmmString s' -> nest 4 $ text "I8[]" <+> text (show s') @@ -157,7 +157,7 @@ pprSection :: Section -> SDoc pprSection (Section t suffix) = section <+> doubleQuotes (pprSectionType t <+> char '.' <+> ppr suffix) where - section = ptext (sLit "section") + section = text "section" pprSectionType :: SectionType -> SDoc pprSectionType s = doubleQuotes (ptext t) diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs index 1f1c7f8e49..77c92407bc 100644 --- a/compiler/cmm/PprCmmExpr.hs +++ b/compiler/cmm/PprCmmExpr.hs @@ -41,7 +41,6 @@ where import CmmExpr import Outputable -import FastString import Data.Maybe import Numeric ( fromRat ) @@ -102,12 +101,12 @@ pprExpr1 e = pprExpr7 e infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc -infixMachOp1 (MO_Eq _) = Just (ptext (sLit "==")) -infixMachOp1 (MO_Ne _) = Just (ptext (sLit "!=")) -infixMachOp1 (MO_Shl _) = Just (ptext (sLit "<<")) -infixMachOp1 (MO_U_Shr _) = Just (ptext (sLit ">>")) -infixMachOp1 (MO_U_Ge _) = Just (ptext (sLit ">=")) -infixMachOp1 (MO_U_Le _) = Just (ptext (sLit "<=")) +infixMachOp1 (MO_Eq _) = Just (text "==") +infixMachOp1 (MO_Ne _) = Just (text "!=") +infixMachOp1 (MO_Shl _) = Just (text "<<") +infixMachOp1 (MO_U_Shr _) = Just (text ">>") +infixMachOp1 (MO_U_Ge _) = Just (text ">=") +infixMachOp1 (MO_U_Le _) = Just (text "<=") infixMachOp1 (MO_U_Gt _) = Just (char '>') infixMachOp1 (MO_U_Lt _) = Just (char '<') infixMachOp1 _ = Nothing @@ -255,24 +254,24 @@ pprGlobalReg gr FloatReg n -> char 'F' <> int n DoubleReg n -> char 'D' <> int n LongReg n -> char 'L' <> int n - XmmReg n -> ptext (sLit "XMM") <> int n - YmmReg n -> ptext (sLit "YMM") <> int n - ZmmReg n -> ptext (sLit "ZMM") <> int n - Sp -> ptext (sLit "Sp") - SpLim -> ptext (sLit "SpLim") - Hp -> ptext (sLit "Hp") - HpLim -> ptext (sLit "HpLim") - MachSp -> ptext (sLit "MachSp") - UnwindReturnReg-> ptext (sLit "UnwindReturnReg") - CCCS -> ptext (sLit "CCCS") - CurrentTSO -> ptext (sLit "CurrentTSO") - CurrentNursery -> ptext (sLit "CurrentNursery") - HpAlloc -> ptext (sLit "HpAlloc") - EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info") - GCEnter1 -> ptext (sLit "stg_gc_enter_1") - GCFun -> ptext (sLit "stg_gc_fun") - BaseReg -> ptext (sLit "BaseReg") - PicBaseReg -> ptext (sLit "PicBaseReg") + XmmReg n -> text "XMM" <> int n + YmmReg n -> text "YMM" <> int n + ZmmReg n -> text "ZMM" <> int n + Sp -> text "Sp" + SpLim -> text "SpLim" + Hp -> text "Hp" + HpLim -> text "HpLim" + MachSp -> text "MachSp" + UnwindReturnReg-> text "UnwindReturnReg" + CCCS -> text "CCCS" + CurrentTSO -> text "CurrentTSO" + CurrentNursery -> text "CurrentNursery" + HpAlloc -> text "HpAlloc" + EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info" + GCEnter1 -> text "stg_gc_enter_1" + GCFun -> text "stg_gc_fun" + BaseReg -> text "BaseReg" + PicBaseReg -> text "PicBaseReg" ----------------------------------------------------------------------------- diff --git a/compiler/cmm/SMRep.hs b/compiler/cmm/SMRep.hs index 6c0076122e..ecd8905cbb 100644 --- a/compiler/cmm/SMRep.hs +++ b/compiler/cmm/SMRep.hs @@ -498,44 +498,44 @@ instance Outputable SMRep where ppr (HeapRep static ps nps tyinfo) = hang (header <+> lbrace) 2 (ppr tyinfo <+> rbrace) where - header = ptext (sLit "HeapRep") - <+> if static then ptext (sLit "static") else empty + header = text "HeapRep" + <+> if static then text "static" else empty <+> pp_n "ptrs" ps <+> pp_n "nonptrs" nps pp_n :: String -> Int -> SDoc pp_n _ 0 = empty pp_n s n = int n <+> text s - ppr (ArrayPtrsRep size _) = ptext (sLit "ArrayPtrsRep") <+> ppr size + ppr (ArrayPtrsRep size _) = text "ArrayPtrsRep" <+> ppr size - ppr (SmallArrayPtrsRep size) = ptext (sLit "SmallArrayPtrsRep") <+> ppr size + ppr (SmallArrayPtrsRep size) = text "SmallArrayPtrsRep" <+> ppr size - ppr (ArrayWordsRep words) = ptext (sLit "ArrayWordsRep") <+> ppr words + ppr (ArrayWordsRep words) = text "ArrayWordsRep" <+> ppr words - ppr (StackRep bs) = ptext (sLit "StackRep") <+> ppr bs + ppr (StackRep bs) = text "StackRep" <+> ppr bs - ppr (RTSRep ty rep) = ptext (sLit "tag:") <> ppr ty <+> ppr rep + ppr (RTSRep ty rep) = text "tag:" <> ppr ty <+> ppr rep instance Outputable ArgDescr where - ppr (ArgSpec n) = ptext (sLit "ArgSpec") <+> ppr n - ppr (ArgGen ls) = ptext (sLit "ArgGen") <+> ppr ls + ppr (ArgSpec n) = text "ArgSpec" <+> ppr n + ppr (ArgGen ls) = text "ArgGen" <+> ppr ls pprTypeInfo :: ClosureTypeInfo -> SDoc pprTypeInfo (Constr tag descr) - = ptext (sLit "Con") <+> - braces (sep [ ptext (sLit "tag:") <+> ppr tag - , ptext (sLit "descr:") <> text (show descr) ]) + = text "Con" <+> + braces (sep [ text "tag:" <+> ppr tag + , text "descr:" <> text (show descr) ]) pprTypeInfo (Fun arity args) - = ptext (sLit "Fun") <+> - braces (sep [ ptext (sLit "arity:") <+> ppr arity + = text "Fun" <+> + braces (sep [ text "arity:" <+> ppr arity , ptext (sLit ("fun_type:")) <+> ppr args ]) pprTypeInfo (ThunkSelector offset) - = ptext (sLit "ThunkSel") <+> ppr offset + = text "ThunkSel" <+> ppr offset -pprTypeInfo Thunk = ptext (sLit "Thunk") -pprTypeInfo BlackHole = ptext (sLit "BlackHole") -pprTypeInfo IndStatic = ptext (sLit "IndStatic") +pprTypeInfo Thunk = text "Thunk" +pprTypeInfo BlackHole = text "BlackHole" +pprTypeInfo IndStatic = text "IndStatic" -- XXX Does not belong here!! stringToWord8s :: String -> [Word8] diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index d10903d78f..d3b9fac34a 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -74,7 +74,6 @@ import CLabel import Id import IdInfo import DataCon -import FastString import Name import Type import TyCoRep @@ -104,8 +103,8 @@ data CgLoc -- and branch to the block id instance Outputable CgLoc where - ppr (CmmLoc e) = ptext (sLit "cmm") <+> ppr e - ppr (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs + ppr (CmmLoc e) = text "cmm" <+> ppr e + ppr (LneLoc b rs) = text "lne" <+> ppr b <+> ppr rs type SelfLoopInfo = (Id, BlockId, [LocalReg]) diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index 4127b67401..8dbb646cdc 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -38,7 +38,6 @@ import MkGraph import BlockId import CmmExpr import CmmUtils -import FastString import Id import VarEnv import Control.Monad @@ -158,7 +157,7 @@ cgLookupPanic id = do local_binds <- getBinds pprPanic "StgCmmEnv: variable not found" (vcat [ppr id, - ptext (sLit "local binds for:"), + text "local binds for:", vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ] ]) diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 42033200c8..2742acdcdb 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -214,7 +214,7 @@ data CgIdInfo instance Outputable CgIdInfo where ppr (CgIdInfo { cg_id = id, cg_loc = loc }) - = ppr id <+> ptext (sLit "-->") <+> ppr loc + = ppr id <+> text "-->" <+> ppr loc -- Sequel tells what to do with the result of this expression data Sequel @@ -232,8 +232,8 @@ data Sequel -- allocating primOp) instance Outputable Sequel where - ppr (Return b) = ptext (sLit "Return") <+> ppr b - ppr (AssignTo regs b) = ptext (sLit "AssignTo") <+> ppr regs <+> ppr b + ppr (Return b) = text "Return" <+> ppr b + ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b -- See Note [sharing continuations] below data ReturnKind diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs index e274ee26be..808629968e 100644 --- a/compiler/coreSyn/CoreArity.hs +++ b/compiler/coreSyn/CoreArity.hs @@ -894,8 +894,8 @@ data EtaInfo = EtaVar Var -- /\a. [], [] a | EtaCo Coercion -- [] |> co, [] |> (sym co) instance Outputable EtaInfo where - ppr (EtaVar v) = ptext (sLit "EtaVar") <+> ppr v - ppr (EtaCo co) = ptext (sLit "EtaCo") <+> ppr co + ppr (EtaVar v) = text "EtaVar" <+> ppr v + ppr (EtaCo co) = text "EtaCo" <+> ppr co pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo] pushCoercion co1 (EtaCo co2 : eis) diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 2f6ab1cb9b..ccd3b8e6fe 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -233,7 +233,7 @@ dumpPassResult dflags unqual mb_flag hdr extra_info binds rules , pprCoreBindingsWithSize binds , ppUnless (null rules) pp_rules ] pp_rules = vcat [ blankLine - , ptext (sLit "------ Local rules for imported ids --------") + , text "------ Local rules for imported ids --------" , pprRules rules ] coreDumpFlag :: CoreToDo -> Maybe DumpFlag @@ -286,9 +286,9 @@ displayLintResults dflags pass warns errs binds | not (isEmptyBag errs) = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs - , ptext (sLit "*** Offending Program ***") + , text "*** Offending Program ***" , pprCoreBindings binds - , ptext (sLit "*** End of Offense ***") ]) + , text "*** End of Offense ***" ]) ; Err.ghcExit dflags 1 } | not (isEmptyBag warns) @@ -301,9 +301,9 @@ displayLintResults dflags pass warns errs binds where lint_banner :: String -> SDoc -> SDoc -lint_banner string pass = ptext (sLit "*** Core Lint") <+> text string - <+> ptext (sLit ": in result of") <+> pass - <+> ptext (sLit "***") +lint_banner string pass = text "*** Core Lint" <+> text string + <+> text ": in result of" <+> pass + <+> text "***" showLintWarnings :: CoreToDo -> Bool -- Disable Lint warnings on the first simplifier pass, because @@ -327,9 +327,9 @@ lintInteractiveExpr what hsc_env expr = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle (vcat [ lint_banner "errors" (text what) , err - , ptext (sLit "*** Offending Program ***") + , text "*** Offending Program ***" , pprCoreExpr expr - , ptext (sLit "*** End of Offense ***") ]) + , text "*** End of Offense ***" ]) ; Err.ghcExit dflags 1 } interactiveInScope :: HscEnv -> [Var] @@ -469,7 +469,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) do { ty <- lintCoreExpr rhs ; lintBinder binder -- Check match to RHS type ; binder_ty <- applySubstTy (idType binder) - ; ensureEqTys binder_ty ty (mkRhsMsg binder (ptext (sLit "RHS")) ty) + ; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") ty) -- Check the let/app invariant -- See Note [CoreSyn let/app invariant] in CoreSyn @@ -494,7 +494,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) ; when (lf_check_inline_loop_breakers flags && isStrongLoopBreaker (idOccInfo binder) && isInlinePragma (idInlinePragma binder)) - (addWarnL (ptext (sLit "INLINE binder is (non-rule) loop breaker:") <+> ppr binder)) + (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder)) -- Only non-rule loop breakers inhibit inlining -- Check whether arity and demand type are consistent (only if demand analysis @@ -511,16 +511,16 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) -- the type and the strictness signature. See Note [exprArity invariant] -- and Note [Trimming arity] ; checkL (idArity binder <= length (typeArity (idType binder))) - (ptext (sLit "idArity") <+> ppr (idArity binder) <+> - ptext (sLit "exceeds typeArity") <+> + (text "idArity" <+> ppr (idArity binder) <+> + text "exceeds typeArity" <+> ppr (length (typeArity (idType binder))) <> colon <+> ppr binder) ; case splitStrictSig (idStrictness binder) of (demands, result_info) | isBotRes result_info -> checkL (idArity binder <= length demands) - (ptext (sLit "idArity") <+> ppr (idArity binder) <+> - ptext (sLit "exceeds arity imposed by the strictness signature") <+> + (text "idArity" <+> ppr (idArity binder) <+> + text "exceeds arity imposed by the strictness signature" <+> ppr (idStrictness binder) <> colon <+> ppr binder) _ -> return () @@ -540,7 +540,7 @@ lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) | isStableSource src = do { ty <- lintCoreExpr rhs - ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (ptext (sLit "unfolding")) ty) } + ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) } lintIdUnfolding _ _ _ = return () -- Do not Lint unstable unfoldings, because that leads -- to exponential behaviour; c.f. CoreFVs.idUnfoldingVars @@ -591,10 +591,10 @@ lintCoreExpr :: CoreExpr -> LintM OutType -- See Note [GHC Formalism] lintCoreExpr (Var var) = do { checkL (not (var == oneTupleDataConId)) - (ptext (sLit "Illegal one-tuple")) + (text "Illegal one-tuple") ; checkL (isId var && not (isCoVar var)) - (ptext (sLit "Non term variable") <+> ppr var) + (text "Non term variable" <+> ppr var) ; checkDeadIdOcc var ; var' <- lookupIdInScope var @@ -608,7 +608,7 @@ lintCoreExpr (Cast expr co) ; co' <- applySubstCo co ; (_, k2, from_ty, to_ty, r) <- lintCoercion co' ; lintL (classifiesTypeWithValues k2) - (ptext (sLit "Target of cast not # or *:") <+> ppr co) + (text "Target of cast not # or *:" <+> ppr co) ; lintRole co' Representational r ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) ; return to_ty } @@ -673,9 +673,9 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = -- See Note [No alternatives lint check] ; when (null alts) $ do { checkL (not (exprIsHNF scrut)) - (ptext (sLit "No alternatives for a case scrutinee in head-normal form:") <+> ppr scrut) + (text "No alternatives for a case scrutinee in head-normal form:" <+> ppr scrut) ; checkL (exprIsBottom scrut) - (ptext (sLit "No alternatives for a case scrutinee not known to diverge for sure:") <+> ppr scrut) + (text "No alternatives for a case scrutinee not known to diverge for sure:" <+> ppr scrut) } -- See Note [Rules for floating-point comparisons] in PrelRules @@ -712,7 +712,7 @@ lintCoreExpr e@(Case scrut var alt_ty alts) = -- This case can't happen; linting types in expressions gets routed through -- lintCoreArgs lintCoreExpr (Type ty) - = failWithL (ptext (sLit "Type found as expression") <+> ppr ty) + = failWithL (text "Type found as expression" <+> ppr ty) lintCoreExpr (Coercion co) = do { (k1, k2, ty1, ty2, role) <- lintInCo co @@ -752,7 +752,7 @@ subtype of the required type, as one would expect. lintCoreArg :: OutType -> CoreArg -> LintM OutType lintCoreArg fun_ty (Type arg_ty) = do { checkL (not (isCoercionTy arg_ty)) - (ptext (sLit "Unnecessary coercion-to-type injection:") + (text "Unnecessary coercion-to-type injection:" <+> ppr arg_ty) ; arg_ty' <- applySubstTy arg_ty ; lintTyApp fun_ty arg_ty' } @@ -825,7 +825,7 @@ checkDeadIdOcc id | isDeadOcc (idOccInfo id) = do { in_case <- inCasePat ; checkL in_case - (ptext (sLit "Occurrence of a dead Id") <+> ppr id) } + (text "Occurrence of a dead Id" <+> ppr id) } | otherwise = return () @@ -981,7 +981,7 @@ lintAndScopeId :: InVar -> (OutVar -> LintM a) -> LintM a lintAndScopeId id linterF = do { flags <- getLintFlags ; checkL (not (lf_check_global_ids flags) || isLocalId id) - (ptext (sLit "Non-local Id binder") <+> ppr id) + (text "Non-local Id binder" <+> ppr id) -- See Note [Checking for global Ids] ; (ty, k) <- lintInTy (idType id) ; lintL (not (isLevityPolymorphic k)) @@ -1027,7 +1027,7 @@ lintType (TyVarTy tv) lintType ty@(AppTy t1 t2) | TyConApp {} <- t1 - = failWithL $ ptext (sLit "TyConApp to the left of AppTy:") <+> ppr ty + = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty | otherwise = do { k1 <- lintType t1 ; k2 <- lintType t2 @@ -1041,7 +1041,7 @@ lintType ty@(TyConApp tc tys) | isUnLiftedTyCon tc || isTypeSynonymTyCon tc || isTypeFamilyTyCon tc -- Also type synonyms and type families , length tys < tyConArity tc - = failWithL (hang (ptext (sLit "Un-saturated type application")) 2 (ppr ty)) + = failWithL (hang (text "Un-saturated type application") 2 (ppr ty)) | otherwise = do { checkTyCon tc @@ -1053,7 +1053,7 @@ lintType ty@(TyConApp tc tys) lintType ty@(ForAllTy (Anon t1) t2) = do { k1 <- lintType t1 ; k2 <- lintType t2 - ; lintArrow (ptext (sLit "type or kind") <+> quotes (ppr ty)) k1 k2 } + ; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 } lintType t@(ForAllTy (Named tv _vis) ty) = do { lintL (isTyVar tv) (text "Covar bound in type:" <+> ppr t) @@ -1082,45 +1082,45 @@ lintKind :: OutKind -> LintM () -- See Note [GHC Formalism] lintKind k = do { sk <- lintType k ; unless ((isStarKind sk) || (isUnliftedTypeKind sk)) - (addErrL (hang (ptext (sLit "Ill-kinded kind:") <+> ppr k) - 2 (ptext (sLit "has kind:") <+> ppr sk))) } + (addErrL (hang (text "Ill-kinded kind:" <+> ppr k) + 2 (text "has kind:" <+> ppr sk))) } -- confirms that a type is really * lintStar :: SDoc -> OutKind -> LintM () lintStar doc k = lintL (classifiesTypeWithValues k) - (ptext (sLit "Non-*-like kind when *-like expected:") <+> ppr k $$ - ptext (sLit "when checking") <+> doc) + (text "Non-*-like kind when *-like expected:" <+> ppr k $$ + text "when checking" <+> doc) lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] lintArrow what k1 k2 -- Eg lintArrow "type or kind `blah'" k1 k2 -- or lintarrow "coercion `blah'" k1 k2 - = do { unless (okArrowArgKind k1) (addErrL (msg (ptext (sLit "argument")) k1)) - ; unless (okArrowResultKind k2) (addErrL (msg (ptext (sLit "result")) k2)) + = do { unless (okArrowArgKind k1) (addErrL (msg (text "argument") k1)) + ; unless (okArrowResultKind k2) (addErrL (msg (text "result") k2)) ; return liftedTypeKind } where msg ar k - = vcat [ hang (ptext (sLit "Ill-kinded") <+> ar) - 2 (ptext (sLit "in") <+> what) - , what <+> ptext (sLit "kind:") <+> ppr k ] + = vcat [ hang (text "Ill-kinded" <+> ar) + 2 (text "in" <+> what) + , what <+> text "kind:" <+> ppr k ] lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind lint_ty_app ty k tys - = lint_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys + = lint_app (text "type" <+> quotes (ppr ty)) k tys ---------------- lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind lint_co_app ty k tys - = lint_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys + = lint_app (text "coercion" <+> quotes (ppr ty)) k tys ---------------- lintTyLit :: TyLit -> LintM () lintTyLit (NumTyLit n) | n >= 0 = return () | otherwise = failWithL msg - where msg = ptext (sLit "Negative type literal:") <+> integer n + where msg = text "Negative type literal:" <+> integer n lintTyLit (StrTyLit _) = return () lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind @@ -1134,9 +1134,9 @@ lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind lint_app doc kfn kas = foldlM go_app kfn kas where - fail_msg = vcat [ hang (ptext (sLit "Kind application error in")) 2 doc - , nest 2 (ptext (sLit "Function kind =") <+> ppr kfn) - , nest 2 (ptext (sLit "Arg kinds =") <+> ppr kas) ] + fail_msg = vcat [ hang (text "Kind application error in") 2 doc + , nest 2 (text "Function kind =" <+> ppr kfn) + , nest 2 (text "Arg kinds =" <+> ppr kas) ] go_app kfn ka | Just kfn' <- coreView kfn @@ -1168,15 +1168,15 @@ lintCoreRule fun_ty (Rule { ru_name = name, ru_bndrs = bndrs do { lhs_ty <- foldM lintCoreArg fun_ty args ; rhs_ty <- lintCoreExpr rhs ; ensureEqTys lhs_ty rhs_ty $ - (rule_doc <+> vcat [ ptext (sLit "lhs type:") <+> ppr lhs_ty - , ptext (sLit "rhs type:") <+> ppr rhs_ty ]) + (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty + , text "rhs type:" <+> ppr rhs_ty ]) ; let bad_bndrs = filterOut (`elemVarSet` exprsFreeVars args) bndrs ; checkL (null bad_bndrs) - (rule_doc <+> ptext (sLit "unbound") <+> ppr bad_bndrs) + (rule_doc <+> text "unbound" <+> ppr bad_bndrs) -- See Note [Linting rules] } where - rule_doc = ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon + rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon {- Note [Linting rules] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -1216,8 +1216,8 @@ lintInCo co lintStarCoercion :: OutCoercion -> LintM (LintedType, LintedType) lintStarCoercion g = do { (k1, k2, t1, t2, r) <- lintCoercion g - ; lintStar (ptext (sLit "the kind of the left type in") <+> ppr g) k1 - ; lintStar (ptext (sLit "the kind of the right type in") <+> ppr g) k2 + ; lintStar (text "the kind of the left type in" <+> ppr g) k1 + ; lintStar (text "the kind of the right type in" <+> ppr g) k2 ; lintRole g Nominal r ; return (t1, t2) } @@ -1236,14 +1236,14 @@ lintCoercion co@(TyConAppCo r tc cos) , [co1,co2] <- cos = do { (k1,k'1,s1,t1,r1) <- lintCoercion co1 ; (k2,k'2,s2,t2,r2) <- lintCoercion co2 - ; k <- lintArrow (ptext (sLit "coercion") <+> quotes (ppr co)) k1 k2 - ; k' <- lintArrow (ptext (sLit "coercion") <+> quotes (ppr co)) k'1 k'2 + ; k <- lintArrow (text "coercion" <+> quotes (ppr co)) k1 k2 + ; k' <- lintArrow (text "coercion" <+> quotes (ppr co)) k'1 k'2 ; lintRole co1 r r1 ; lintRole co2 r r2 ; return (k, k', mkFunTy s1 s2, mkFunTy t1 t2, r) } | Just {} <- synTyConDefn_maybe tc - = failWithL (ptext (sLit "Synonym in TyConAppCo:") <+> ppr co) + = failWithL (text "Synonym in TyConAppCo:" <+> ppr co) | otherwise = do { checkTyCon tc @@ -1255,9 +1255,9 @@ lintCoercion co@(TyConAppCo r tc cos) lintCoercion co@(AppCo co1 co2) | TyConAppCo {} <- co1 - = failWithL (ptext (sLit "TyConAppCo to the left of AppCo:") <+> ppr co) + = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co) | Refl _ (TyConApp {}) <- co1 - = failWithL (ptext (sLit "Refl (TyConApp ...) to the left of AppCo:") <+> ppr co) + = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co) | otherwise = do { (k1,k2,s1,s2,r1) <- lintCoercion co1 ; (k'1, k'2, t1, t2, r2) <- lintCoercion co2 @@ -1265,7 +1265,7 @@ lintCoercion co@(AppCo co1 co2) ; k4 <- lint_co_app co k2 [(t2,k'2)] ; if r1 == Phantom then lintL (r2 == Phantom || r2 == Nominal) - (ptext (sLit "Second argument in AppCo cannot be R:") $$ + (text "Second argument in AppCo cannot be R:" $$ ppr co) else lintRole co Nominal r2 ; return (k3, k4, mkAppTy s1 t1, mkAppTy s2 t2, r1) } @@ -1282,8 +1282,8 @@ lintCoercion (ForAllCo tv1 kind_co co) lintCoercion (CoVarCo cv) | not (isCoVar cv) - = failWithL (hang (ptext (sLit "Bad CoVarCo:") <+> ppr cv) - 2 (ptext (sLit "With offending type:") <+> ppr (varType cv))) + = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv) + 2 (text "With offending type:" <+> ppr (varType cv))) | otherwise = do { lintTyCoVarInScope cv ; cv' <- lookupIdInScope cv @@ -1360,7 +1360,7 @@ lintCoercion co@(TransCo co1 co2) = do { (k1a, _k1b, ty1a, ty1b, r1) <- lintCoercion co1 ; (_k2a, k2b, ty2a, ty2b, r2) <- lintCoercion co2 ; ensureEqTys ty1b ty2a - (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co) + (hang (text "Trans coercion mis-match:" <+> ppr co) 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b])) ; lintRole co r1 r2 ; return (k1a, k2b, ty1a, ty2b, r1) } @@ -1392,7 +1392,7 @@ lintCoercion the_co@(NthCo n co) ks = typeKind ts kt = typeKind tt - ; _ -> failWithL (hang (ptext (sLit "Bad getNth:")) + ; _ -> failWithL (hang (text "Bad getNth:") 2 (ppr the_co $$ ppr s $$ ppr t)) }}} lintCoercion the_co@(LRCo lr co) @@ -1407,7 +1407,7 @@ lintCoercion the_co@(LRCo lr co) ks_pick = typeKind s_pick kt_pick = typeKind t_pick - _ -> failWithL (hang (ptext (sLit "Bad LRCo:")) + _ -> failWithL (hang (text "Bad LRCo:") 2 (ppr the_co $$ ppr s $$ ppr t)) } lintCoercion (InstCo co arg) @@ -1422,8 +1422,8 @@ lintCoercion (InstCo co arg) substTyWith [tv1] [s1] t1, substTyWith [tv2] [s2] t2, r) | otherwise - -> failWithL (ptext (sLit "Kind mis-match in inst coercion")) - _ -> failWithL (ptext (sLit "Bad argument of inst")) } + -> failWithL (text "Kind mis-match in inst coercion") + _ -> failWithL (text "Bad argument of inst") } lintCoercion co@(AxiomInstCo con ind cos) = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con)) @@ -1646,7 +1646,7 @@ addMsg env msgs msg (loc, cxt1) = dumpLoc (head locs) cxts = [snd (dumpLoc loc) | loc <- locs] context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$ - ptext (sLit "Substitution:") <+> ppr (le_subst env) + text "Substitution:" <+> ppr (le_subst env) | otherwise = cxt1 mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg) @@ -1702,14 +1702,14 @@ lookupIdInScope id Nothing -> do { addErrL out_of_scope ; return id } } where - out_of_scope = pprBndr LetBind id <+> ptext (sLit "is out of scope") + out_of_scope = pprBndr LetBind id <+> text "is out of scope" oneTupleDataConId :: Id -- Should not happen oneTupleDataConId = dataConWorkId (tupleDataCon Boxed 1) lintTyCoVarInScope :: Var -> LintM () -lintTyCoVarInScope v = lintInScope (ptext (sLit "is out of scope")) v +lintTyCoVarInScope v = lintInScope (text "is out of scope") v lintInScope :: SDoc -> Var -> LintM () lintInScope loc_msg var = @@ -1730,9 +1730,9 @@ lintRole :: Outputable thing -> LintM () lintRole co r1 r2 = lintL (r1 == r2) - (ptext (sLit "Role incompatibility: expected") <+> ppr r1 <> comma <+> - ptext (sLit "got") <+> ppr r2 $$ - ptext (sLit "in") <+> ppr co) + (text "Role incompatibility: expected" <+> ppr r1 <> comma <+> + text "got" <+> ppr r2 $$ + text "in" <+> ppr co) {- ************************************************************************ @@ -1745,16 +1745,16 @@ lintRole co r1 r2 dumpLoc :: LintLocInfo -> (SrcLoc, SDoc) dumpLoc (RhsOf v) - = (getSrcLoc v, brackets (ptext (sLit "RHS of") <+> pp_binders [v])) + = (getSrcLoc v, brackets (text "RHS of" <+> pp_binders [v])) dumpLoc (LambdaBodyOf b) - = (getSrcLoc b, brackets (ptext (sLit "in body of lambda with binder") <+> pp_binder b)) + = (getSrcLoc b, brackets (text "in body of lambda with binder" <+> pp_binder b)) dumpLoc (BodyOfLetRec []) - = (noSrcLoc, brackets (ptext (sLit "In body of a letrec with no binders"))) + = (noSrcLoc, brackets (text "In body of a letrec with no binders")) dumpLoc (BodyOfLetRec bs@(_:_)) - = ( getSrcLoc (head bs), brackets (ptext (sLit "in body of letrec with binders") <+> pp_binders bs)) + = ( getSrcLoc (head bs), brackets (text "in body of letrec with binders" <+> pp_binders bs)) dumpLoc (AnExpr e) = (noSrcLoc, text "In the expression:" <+> ppr e) @@ -1766,7 +1766,7 @@ dumpLoc (CasePat (con, args, _)) = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) dumpLoc (ImportedUnfolding locn) - = (locn, brackets (ptext (sLit "in an imported unfolding"))) + = (locn, brackets (text "in an imported unfolding")) dumpLoc TopLevelBindings = (noSrcLoc, Outputable.empty) dumpLoc (InType ty) @@ -1799,7 +1799,7 @@ mkScrutMsg var var_ty scrut_ty subst = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, text "Result binder type:" <+> ppr var_ty,--(idType var), text "Scrutinee type:" <+> ppr scrut_ty, - hsep [ptext (sLit "Current TCv subst"), ppr subst]] + hsep [text "Current TCv subst", ppr subst]] mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc mkNonDefltMsg e @@ -1849,98 +1849,98 @@ mkNewTyDataConAltMsg scrut_ty alt mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc mkAppMsg fun_ty arg_ty arg - = vcat [ptext (sLit "Argument value doesn't match argument type:"), - hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty), - hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), - hang (ptext (sLit "Arg:")) 4 (ppr arg)] + = vcat [text "Argument value doesn't match argument type:", + hang (text "Fun type:") 4 (ppr fun_ty), + hang (text "Arg type:") 4 (ppr arg_ty), + hang (text "Arg:") 4 (ppr arg)] mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc mkNonFunAppMsg fun_ty arg_ty arg - = vcat [ptext (sLit "Non-function type in function position"), - hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty), - hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), - hang (ptext (sLit "Arg:")) 4 (ppr arg)] + = vcat [text "Non-function type in function position", + hang (text "Fun type:") 4 (ppr fun_ty), + hang (text "Arg type:") 4 (ppr arg_ty), + hang (text "Arg:") 4 (ppr arg)] mkLetErr :: TyVar -> CoreExpr -> MsgDoc mkLetErr bndr rhs - = vcat [ptext (sLit "Bad `let' binding:"), - hang (ptext (sLit "Variable:")) + = vcat [text "Bad `let' binding:", + hang (text "Variable:") 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)), - hang (ptext (sLit "Rhs:")) + hang (text "Rhs:") 4 (ppr rhs)] mkTyAppMsg :: Type -> Type -> MsgDoc mkTyAppMsg ty arg_ty = vcat [text "Illegal type application:", - hang (ptext (sLit "Exp type:")) + hang (text "Exp type:") 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), - hang (ptext (sLit "Arg type:")) + hang (text "Arg type:") 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc mkRhsMsg binder what ty = vcat - [hsep [ptext (sLit "The type of this binder doesn't match the type of its") <+> what <> colon, + [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon, ppr binder], - hsep [ptext (sLit "Binder's type:"), ppr (idType binder)], - hsep [ptext (sLit "Rhs type:"), ppr ty]] + hsep [text "Binder's type:", ppr (idType binder)], + hsep [text "Rhs type:", ppr ty]] mkLetAppMsg :: CoreExpr -> MsgDoc mkLetAppMsg e - = hang (ptext (sLit "This argument does not satisfy the let/app invariant:")) + = hang (text "This argument does not satisfy the let/app invariant:") 2 (ppr e) mkRhsPrimMsg :: Id -> CoreExpr -> MsgDoc mkRhsPrimMsg binder _rhs - = vcat [hsep [ptext (sLit "The type of this binder is primitive:"), + = vcat [hsep [text "The type of this binder is primitive:", ppr binder], - hsep [ptext (sLit "Binder's type:"), ppr (idType binder)] + hsep [text "Binder's type:", ppr (idType binder)] ] mkStrictMsg :: Id -> MsgDoc mkStrictMsg binder - = vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"), + = vcat [hsep [text "Recursive or top-level binder has strict demand info:", ppr binder], - hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)] + hsep [text "Binder's demand info:", ppr (idDemandInfo binder)] ] mkNonTopExportedMsg :: Id -> MsgDoc mkNonTopExportedMsg binder - = hsep [ptext (sLit "Non-top-level binder is marked as exported:"), ppr binder] + = hsep [text "Non-top-level binder is marked as exported:", ppr binder] mkNonTopExternalNameMsg :: Id -> MsgDoc mkNonTopExternalNameMsg binder - = hsep [ptext (sLit "Non-top-level binder has an external name:"), ppr binder] + = hsep [text "Non-top-level binder has an external name:", ppr binder] mkKindErrMsg :: TyVar -> Type -> MsgDoc mkKindErrMsg tyvar arg_ty - = vcat [ptext (sLit "Kinds don't match in type application:"), - hang (ptext (sLit "Type variable:")) + = vcat [text "Kinds don't match in type application:", + hang (text "Type variable:") 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), - hang (ptext (sLit "Arg type:")) + hang (text "Arg type:") 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] {- Not needed now mkArityMsg :: Id -> MsgDoc mkArityMsg binder - = vcat [hsep [ptext (sLit "Demand type has"), + = vcat [hsep [text "Demand type has", ppr (dmdTypeDepth dmd_ty), - ptext (sLit "arguments, rhs has"), + text "arguments, rhs has", ppr (idArity binder), - ptext (sLit "arguments,"), + text "arguments,", ppr binder], - hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty] + hsep [text "Binder's strictness signature:", ppr dmd_ty] ] where (StrictSig dmd_ty) = idStrictness binder -} mkCastErr :: Outputable casted => casted -> Coercion -> Type -> Type -> MsgDoc mkCastErr expr co from_ty expr_ty - = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"), - ptext (sLit "From-type:") <+> ppr from_ty, - ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty, - ptext (sLit "Actual enclosed expr:") <+> ppr expr, - ptext (sLit "Coercion used in cast:") <+> ppr co + = vcat [text "From-type of Cast differs from type of enclosed expression", + text "From-type:" <+> ppr from_ty, + text "Type of enclosed expr:" <+> ppr expr_ty, + text "Actual enclosed expr:" <+> ppr expr, + text "Coercion used in cast:" <+> ppr co ] mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc @@ -1956,21 +1956,21 @@ mkBadProofIrrelMsg ty co mkBadTyVarMsg :: Var -> SDoc mkBadTyVarMsg tv - = ptext (sLit "Non-tyvar used in TyVarTy:") + = text "Non-tyvar used in TyVarTy:" <+> ppr tv <+> dcolon <+> ppr (varType tv) pprLeftOrRight :: LeftOrRight -> MsgDoc -pprLeftOrRight CLeft = ptext (sLit "left") -pprLeftOrRight CRight = ptext (sLit "right") +pprLeftOrRight CLeft = text "left" +pprLeftOrRight CRight = text "right" dupVars :: [[Var]] -> MsgDoc dupVars vars - = hang (ptext (sLit "Duplicate variables brought into scope")) + = hang (text "Duplicate variables brought into scope") 2 (ppr vars) dupExtVars :: [[Name]] -> MsgDoc dupExtVars vars - = hang (ptext (sLit "Duplicate top-level variables with the same qualified name")) + = hang (text "Duplicate top-level variables with the same qualified name") 2 (ppr vars) {- diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs index df18f8b5f1..724f72bbc4 100644 --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -992,13 +992,13 @@ instance Outputable FloatingBind where ppr (FloatTick t) = ppr t instance Outputable Floats where - ppr (Floats flag fs) = ptext (sLit "Floats") <> brackets (ppr flag) <+> + ppr (Floats flag fs) = text "Floats" <> brackets (ppr flag) <+> braces (vcat (map ppr (fromOL fs))) instance Outputable OkToSpec where - ppr OkToSpec = ptext (sLit "OkToSpec") - ppr IfUnboxedOk = ptext (sLit "IfUnboxedOk") - ppr NotOkToSpec = ptext (sLit "NotOkToSpec") + ppr OkToSpec = text "OkToSpec" + ppr IfUnboxedOk = text "IfUnboxedOk" + ppr NotOkToSpec = text "NotOkToSpec" -- Can we float these binds out of the rhs of a let? We cache this decision -- to avoid having to recompute it in a non-linear way when there are diff --git a/compiler/coreSyn/CoreStats.hs b/compiler/coreSyn/CoreStats.hs index 456943cce3..9ad83214ce 100644 --- a/compiler/coreSyn/CoreStats.hs +++ b/compiler/coreSyn/CoreStats.hs @@ -15,7 +15,6 @@ import CoreSyn import Outputable import Coercion import Var -import FastString (sLit) import Type (Type, typeSize, seqType) import Id (idType) import CoreSeq (megaSeqIdInfo) @@ -27,9 +26,9 @@ data CoreStats = CS { cs_tm :: Int -- Terms instance Outputable CoreStats where ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3 }) - = braces (sep [ptext (sLit "terms:") <+> intWithCommas i1 <> comma, - ptext (sLit "types:") <+> intWithCommas i2 <> comma, - ptext (sLit "coercions:") <+> intWithCommas i3]) + = braces (sep [text "terms:" <+> intWithCommas i1 <> comma, + text "types:" <+> intWithCommas i2 <> comma, + text "coercions:" <+> intWithCommas i3]) plusCS :: CoreStats -> CoreStats -> CoreStats plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1 }) diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs index bc96d0f756..8cc609ddf4 100644 --- a/compiler/coreSyn/CoreSubst.hs +++ b/compiler/coreSyn/CoreSubst.hs @@ -231,7 +231,7 @@ extendTCvSubst subst v r | Just co <- isCoercionTy_maybe r = extendCvSubst subst v co | otherwise - = pprPanic "CoreSubst.extendTCvSubst" (ppr v <+> ptext (sLit "|->") <+> ppr r) + = pprPanic "CoreSubst.extendTCvSubst" (ppr v <+> text "|->" <+> ppr r) -- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTCvSubst' extendTCvSubstList :: Subst -> [(TyVar,Type)] -> Subst @@ -274,7 +274,7 @@ lookupIdSubst doc (Subst in_scope ids _ _) v | Just e <- lookupVarEnv ids v = e | Just v' <- lookupInScope in_scope v = Var v' -- Vital! See Note [Extending the Subst] - | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> doc <+> ppr v + | otherwise = WARN( True, text "CoreSubst.lookupIdSubst" <+> doc <+> ppr v $$ ppr in_scope) Var v @@ -344,10 +344,10 @@ setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs instance Outputable Subst where ppr (Subst in_scope ids tvs cvs) - = ptext (sLit "<InScope =") <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope)))) - $$ ptext (sLit " IdSubst =") <+> ppr ids - $$ ptext (sLit " TvSubst =") <+> ppr tvs - $$ ptext (sLit " CvSubst =") <+> ppr cvs + = text "<InScope =" <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope)))) + $$ text " IdSubst =" <+> ppr ids + $$ text " TvSubst =" <+> ppr tvs + $$ text " CvSubst =" <+> ppr cvs <> char '>' {- @@ -714,7 +714,7 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args -- Do NOT optimise the RHS (previously we did simplOptExpr here) -- See Note [Substitute lazily] where - doc = ptext (sLit "subst-rule") <+> ppr fn_name + doc = text "subst-rule" <+> ppr fn_name (subst', bndrs') = substBndrs subst bndrs ------------------ diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs index cd3bcb1b02..c725dc3737 100644 --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -102,7 +102,6 @@ import Module import TyCon import BasicTypes import DynFlags -import FastString import Outputable import Util import SrcLoc ( RealSrcSpan, containsSpan ) @@ -1327,7 +1326,7 @@ the occurrence info is wrong instance Outputable AltCon where ppr (DataAlt dc) = ppr dc ppr (LitAlt lit) = ppr lit - ppr DEFAULT = ptext (sLit "__DEFAULT") + ppr DEFAULT = text "__DEFAULT" cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2 diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs index d033dde30d..2a7906a908 100644 --- a/compiler/coreSyn/CoreUnfold.hs +++ b/compiler/coreSyn/CoreUnfold.hs @@ -59,7 +59,6 @@ import PrelNames import TysPrim ( realWorldStatePrimTy ) import Bag import Util -import FastString import Outputable import ForeignCall @@ -181,7 +180,7 @@ specUnfolding _dflags subst new_bndrs spec_args specUnfolding _ _ _ _ _ = noUnfolding spec_doc :: SDoc -spec_doc = ptext (sLit "specUnfolding") +spec_doc = text "specUnfolding" {- Note [Specialising unfoldings] @@ -864,7 +863,7 @@ data ExprSize } instance Outputable ExprSize where - ppr TooBig = ptext (sLit "TooBig") + ppr TooBig = text "TooBig" ppr (SizeIs a _ c) = brackets (int a <+> int c) -- subtract the discount before deciding whether to bale out. eg. we @@ -996,9 +995,9 @@ data ArgSummary = TrivArg -- Nothing interesting -- ..or con-like. Note [Conlike is interesting] instance Outputable ArgSummary where - ppr TrivArg = ptext (sLit "TrivArg") - ppr NonTrivArg = ptext (sLit "NonTrivArg") - ppr ValueArg = ptext (sLit "ValueArg") + ppr TrivArg = text "TrivArg" + ppr NonTrivArg = text "NonTrivArg" + ppr ValueArg = text "ValueArg" nonTriv :: ArgSummary -> Bool nonTriv TrivArg = False @@ -1018,12 +1017,12 @@ data CallCtxt -- that decomposes its scrutinee instance Outputable CallCtxt where - ppr CaseCtxt = ptext (sLit "CaseCtxt") - ppr ValAppCtxt = ptext (sLit "ValAppCtxt") - ppr BoringCtxt = ptext (sLit "BoringCtxt") - ppr RhsCtxt = ptext (sLit "RhsCtxt") - ppr DiscArgCtxt = ptext (sLit "DiscArgCtxt") - ppr RuleArgCtxt = ptext (sLit "RuleArgCtxt") + ppr CaseCtxt = text "CaseCtxt" + ppr ValAppCtxt = text "ValAppCtxt" + ppr BoringCtxt = text "BoringCtxt" + ppr RhsCtxt = text "RhsCtxt" + ppr DiscArgCtxt = text "DiscArgCtxt" + ppr RuleArgCtxt = text "RuleArgCtxt" callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info = case idUnfolding id of @@ -1055,7 +1054,7 @@ tryUnfolding dflags id lone_variable arg_infos cont_info unf_template is_top is_wf is_exp guidance = case guidance of - UnfNever -> traceInline dflags str (ptext (sLit "UnfNever")) Nothing + UnfNever -> traceInline dflags str (text "UnfNever") Nothing UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } | enough_args && (boring_ok || some_benefit) diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index d89612aee1..9c2f16c127 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -183,10 +183,10 @@ applyTypeToArgs e op_ty args go_ty_args op_ty rev_tys args = go (applyTysD panic_msg_w_hdr op_ty (reverse rev_tys)) args - panic_msg_w_hdr = hang (ptext (sLit "applyTypeToArgs")) 2 panic_msg - panic_msg = vcat [ ptext (sLit "Expression:") <+> pprCoreExpr e - , ptext (sLit "Type:") <+> ppr op_ty - , ptext (sLit "Args:") <+> ppr args ] + panic_msg_w_hdr = hang (text "applyTypeToArgs") 2 panic_msg + panic_msg = vcat [ text "Expression:" <+> pprCoreExpr e + , text "Type:" <+> ppr op_ty + , text "Args:" <+> ppr args ] {- @@ -202,8 +202,8 @@ applyTypeToArgs e op_ty args mkCast :: CoreExpr -> Coercion -> CoreExpr mkCast e co | ASSERT2( coercionRole co == Representational - , ptext (sLit "coercion") <+> ppr co <+> ptext (sLit "passed to mkCast") - <+> ppr e <+> ptext (sLit "has wrong role") <+> ppr (coercionRole co) ) + , text "coercion" <+> ppr co <+> ptext (sLit "passed to mkCast") + <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co) ) isReflCo co = e @@ -218,9 +218,9 @@ mkCast (Cast expr co2) co = WARN(let { Pair from_ty _to_ty = coercionKind co; Pair _from_ty2 to_ty2 = coercionKind co2} in not (from_ty `eqType` to_ty2), - vcat ([ ptext (sLit "expr:") <+> ppr expr - , ptext (sLit "co2:") <+> ppr co2 - , ptext (sLit "co:") <+> ppr co ]) ) + vcat ([ text "expr:" <+> ppr expr + , text "co2:" <+> ppr co2 + , text "co:" <+> ppr co ]) ) mkCast expr (mkTransCo co2 co) mkCast (Tick t expr) co diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs index e869ebede6..e012f2c4be 100644 --- a/compiler/coreSyn/MkCore.hs +++ b/compiler/coreSyn/MkCore.hs @@ -366,8 +366,8 @@ data FloatBind -- See Note [Floating cases] in SetLevels instance Outputable FloatBind where - ppr (FloatLet b) = ptext (sLit "LET") <+> ppr b - ppr (FloatCase e b c bs) = hang (ptext (sLit "CASE") <+> ppr e <+> ptext (sLit "of") <+> ppr b) + ppr (FloatLet b) = text "LET" <+> ppr b + ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> ptext (sLit "of") <+> ppr b) 2 (ppr c <+> ppr bs) wrapFloat :: FloatBind -> CoreExpr -> CoreExpr diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs index 147ff318cd..9ce1dad62f 100644 --- a/compiler/coreSyn/PprCore.hs +++ b/compiler/coreSyn/PprCore.hs @@ -76,7 +76,7 @@ type Annotation b = Expr b -> SDoc -- | Annotate with the size of the right-hand-side sizeAnn :: CoreExpr -> SDoc -sizeAnn e = ptext (sLit "-- RHS size:") <+> ppr (exprStats e) +sizeAnn e = text "-- RHS size:" <+> ppr (exprStats e) -- | No annotation noAnn :: Expr b -> SDoc @@ -94,12 +94,12 @@ pprTopBind ann (NonRec binder expr) = ppr_binding ann (binder,expr) $$ blankLine pprTopBind _ (Rec []) - = ptext (sLit "Rec { }") + = text "Rec { }" pprTopBind ann (Rec (b:bs)) - = vcat [ptext (sLit "Rec {"), + = vcat [text "Rec {", ppr_binding ann b, vcat [blankLine $$ ppr_binding ann b | b <- bs], - ptext (sLit "end Rec }"), + text "end Rec }", blankLine] ppr_bind :: OutputableBndr b => Annotation b -> Bind b -> SDoc @@ -123,7 +123,7 @@ noParens pp = pp pprOptCo :: Coercion -> SDoc pprOptCo co = sdocWithDynFlags $ \dflags -> if gopt Opt_SuppressCoercions dflags - then ptext (sLit "...") + then text "..." else parens (sep [ppr co, dcolon <+> ppr (coercionType co)]) ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc @@ -131,19 +131,19 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc -- an atomic value (e.g. function args) ppr_expr _ (Var name) = ppr name -ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE:") <+> ppr ty) -- Weird -ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO:") <+> ppr co) +ppr_expr add_par (Type ty) = add_par (text "TYPE:" <+> ppr ty) -- Weird +ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co) ppr_expr add_par (Lit lit) = pprLiteral add_par lit ppr_expr add_par (Cast expr co) - = add_par $ sep [pprParendExpr expr, ptext (sLit "`cast`") <+> pprOptCo co] + = add_par $ sep [pprParendExpr expr, text "`cast`" <+> pprOptCo co] ppr_expr add_par expr@(Lam _ _) = let (bndrs, body) = collectBinders expr in add_par $ - hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) + hang (text "\\" <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) 2 (pprCoreExpr body) ppr_expr add_par expr@(App {}) @@ -180,18 +180,18 @@ ppr_expr add_par (Case expr var ty [(con,args,rhs)]) = sdocWithDynFlags $ \dflags -> if gopt Opt_PprCaseAsLet dflags then add_par $ -- See Note [Print case as let] - sep [ sep [ ptext (sLit "let! {") + sep [ sep [ text "let! {" <+> ppr_case_pat con args - <+> ptext (sLit "~") + <+> text "~" <+> ppr_bndr var - , ptext (sLit "<-") <+> ppr_expr id expr - <+> ptext (sLit "} in") ] + , text "<-" <+> ppr_expr id expr + <+> text "} in" ] , pprCoreExpr rhs ] else add_par $ - sep [sep [ptext (sLit "case") <+> pprCoreExpr expr, + sep [sep [text "case" <+> pprCoreExpr expr, ifPprDebug (text "return" <+> ppr ty), - sep [ptext (sLit "of") <+> ppr_bndr var, + sep [text "of" <+> ppr_bndr var, char '{' <+> ppr_case_pat con args <+> arrow] ], pprCoreExpr rhs, @@ -202,10 +202,10 @@ ppr_expr add_par (Case expr var ty [(con,args,rhs)]) ppr_expr add_par (Case expr var ty alts) = add_par $ - sep [sep [ptext (sLit "case") + sep [sep [text "case" <+> pprCoreExpr expr <+> ifPprDebug (text "return" <+> ppr ty), - ptext (sLit "of") <+> ppr_bndr var <+> char '{'], + text "of" <+> ppr_bndr var <+> char '{'], nest 2 (vcat (punctuate semi (map pprCoreAlt alts))), char '}' ] @@ -220,16 +220,16 @@ ppr_expr add_par (Case expr var ty alts) ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) = add_par $ vcat [ - hsep [ptext (sLit "let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals], + hsep [text "let {", (pprBndr LetBind val_bdr $$ ppr val_bndr), equals], nest 2 (pprCoreExpr rhs), - ptext (sLit "} in"), + text "} in", pprCoreExpr body ] ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) = add_par - (hang (ptext (sLit "let {")) + (hang (text "let {") 2 (hsep [ppr_binding (val_bdr,rhs), - ptext (sLit "} in")]) + text "} in"]) $$ pprCoreExpr expr) -} @@ -237,7 +237,7 @@ ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) -- General case (recursive case, too) ppr_expr add_par (Let bind expr) = add_par $ - sep [hang (ptext keyword) 2 (ppr_bind noAnn bind <+> ptext (sLit "} in")), + sep [hang (ptext keyword) 2 (ppr_bind noAnn bind <+> text "} in"), pprCoreExpr expr] where keyword = case bind of @@ -274,8 +274,8 @@ pprArg (Type ty) = sdocWithDynFlags $ \dflags -> if gopt Opt_SuppressTypeApplications dflags then empty - else ptext (sLit "@") <+> pprParendType ty -pprArg (Coercion co) = ptext (sLit "@~") <+> pprOptCo co + else text "@" <+> pprParendType ty +pprArg (Coercion co) = text "@~" <+> pprOptCo co pprArg expr = pprParendExpr expr {- @@ -312,7 +312,7 @@ pprCoreBinder bind_site bndr pprUntypedBinder :: Var -> SDoc pprUntypedBinder binder - | isTyVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind + | isTyVar binder = text "@" <+> ppr binder -- NB: don't print kind | otherwise = pprIdBndr binder pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc @@ -339,7 +339,7 @@ pprTypedLamBinder bind_site debug_on var suppress_sigs = gopt Opt_SuppressTypeSignatures unf_info = unfoldingInfo (idInfo var) - pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info + pp_unf | hasSomeUnfolding unf_info = text "Unf=" <> ppr unf_info | otherwise = empty pprTypedLetBinder :: Var -> SDoc @@ -355,7 +355,7 @@ pprTypedLetBinder binder pprKindedTyVarBndr :: TyVar -> SDoc -- Print a type variable binder with its kind (but not if *) pprKindedTyVarBndr tyvar - = ptext (sLit "@") <+> pprTvBndr tyvar + = text "@" <+> pprTvBndr tyvar -- pprIdBndr does *not* print the type -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness @@ -379,10 +379,10 @@ pprIdBndrInfo info has_lbv = not (hasNoOneShotInfo lbv_info) doc = showAttributes - [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info) - , (has_occ, ptext (sLit "Occ=") <> ppr occ_info) - , (has_dmd, ptext (sLit "Dmd=") <> ppr dmd_info) - , (has_lbv , ptext (sLit "OS=") <> ppr lbv_info) + [ (has_prag, text "InlPrag=" <> ppr prag_info) + , (has_occ, text "Occ=" <> ppr occ_info) + , (has_dmd, text "Dmd=" <> ppr dmd_info) + , (has_lbv , text "OS=" <> ppr lbv_info) ] {- @@ -397,19 +397,19 @@ ppIdInfo id info ppUnless (gopt Opt_SuppressIdInfo dflags) $ showAttributes [ (True, pp_scope <> ppr (idDetails id)) - , (has_arity, ptext (sLit "Arity=") <> int arity) - , (has_called_arity, ptext (sLit "CallArity=") <> int called_arity) - , (has_caf_info, ptext (sLit "Caf=") <> ppr caf_info) - , (True, ptext (sLit "Str=") <> pprStrictness str_info) - , (has_unf, ptext (sLit "Unf=") <> ppr unf_info) - , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules)) + , (has_arity, text "Arity=" <> int arity) + , (has_called_arity, text "CallArity=" <> int called_arity) + , (has_caf_info, text "Caf=" <> ppr caf_info) + , (True, text "Str=" <> pprStrictness str_info) + , (has_unf, text "Unf=" <> ppr unf_info) + , (not (null rules), text "RULES:" <+> vcat (map pprRule rules)) ] -- Inline pragma, occ, demand, one-shot info -- printed out with all binders (when debug is on); -- see PprCore.pprIdBndr where - pp_scope | isGlobalId id = ptext (sLit "GblId") - | isExportedId id = ptext (sLit "LclIdX") - | otherwise = ptext (sLit "LclId") + pp_scope | isGlobalId id = text "GblId" + | isExportedId id = text "LclIdX" + | otherwise = text "LclId" arity = arityInfo info has_arity = arity /= 0 @@ -441,47 +441,47 @@ showAttributes stuff -} instance Outputable UnfoldingGuidance where - ppr UnfNever = ptext (sLit "NEVER") + ppr UnfNever = text "NEVER" ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }) - = ptext (sLit "ALWAYS_IF") <> - parens (ptext (sLit "arity=") <> int arity <> comma <> - ptext (sLit "unsat_ok=") <> ppr unsat_ok <> comma <> - ptext (sLit "boring_ok=") <> ppr boring_ok) + = text "ALWAYS_IF" <> + parens (text "arity=" <> int arity <> comma <> + text "unsat_ok=" <> ppr unsat_ok <> comma <> + text "boring_ok=" <> ppr boring_ok) ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount }) - = hsep [ ptext (sLit "IF_ARGS"), + = hsep [ text "IF_ARGS", brackets (hsep (map int cs)), int size, int discount ] instance Outputable UnfoldingSource where - ppr InlineCompulsory = ptext (sLit "Compulsory") - ppr InlineStable = ptext (sLit "InlineStable") - ppr InlineRhs = ptext (sLit "<vanilla>") + ppr InlineCompulsory = text "Compulsory" + ppr InlineStable = text "InlineStable" + ppr InlineRhs = text "<vanilla>" instance Outputable Unfolding where - ppr NoUnfolding = ptext (sLit "No unfolding") - ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs + ppr NoUnfolding = text "No unfolding" + ppr (OtherCon cs) = text "OtherCon" <+> ppr cs ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) - = hang (ptext (sLit "DFun:") <+> ptext (sLit "\\") + = hang (text "DFun:" <+> ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) 2 (ppr con <+> sep (map ppr args)) ppr (CoreUnfolding { uf_src = src , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf , uf_is_conlike=conlike, uf_is_work_free=wf , uf_expandable=exp, uf_guidance=g }) - = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs) + = text "Unf" <> braces (pp_info $$ pp_rhs) where pp_info = fsep $ punctuate comma - [ ptext (sLit "Src=") <> ppr src - , ptext (sLit "TopLvl=") <> ppr top - , ptext (sLit "Value=") <> ppr hnf - , ptext (sLit "ConLike=") <> ppr conlike - , ptext (sLit "WorkFree=") <> ppr wf - , ptext (sLit "Expandable=") <> ppr exp - , ptext (sLit "Guidance=") <> ppr g ] + [ text "Src=" <> ppr src + , text "TopLvl=" <> ppr top + , text "Value=" <> ppr hnf + , text "ConLike=" <> ppr conlike + , text "WorkFree=" <> ppr wf + , text "Expandable=" <> ppr exp + , text "Guidance=" <> ppr g ] pp_tmpl = sdocWithDynFlags $ \dflags -> ppUnless (gopt Opt_SuppressUnfoldings dflags) $ - ptext (sLit "Tmpl=") <+> ppr rhs + text "Tmpl=" <+> ppr rhs pp_rhs | isStableSource src = pp_tmpl | otherwise = empty -- Don't print the RHS or we get a quadratic @@ -501,16 +501,16 @@ pprRules rules = vcat (map pprRule rules) pprRule :: CoreRule -> SDoc pprRule (BuiltinRule { ru_fn = fn, ru_name = name}) - = ptext (sLit "Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name) + = text "Built in rule for" <+> ppr fn <> colon <+> doubleQuotes (ftext name) pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) = hang (doubleQuotes (ftext name) <+> ppr act) - 4 (sep [ptext (sLit "forall") <+> + 4 (sep [text "forall" <+> sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot, nest 2 (ppr fn <+> sep (map pprArg tpl_args)), - nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs) + nest 2 (text "=" <+> pprCoreExpr rhs) ]) {- @@ -521,24 +521,24 @@ pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, instance Outputable id => Outputable (Tickish id) where ppr (HpcTick modl ix) = - hcat [ptext (sLit "hpc<"), + hcat [text "hpc<", ppr modl, comma, ppr ix, - ptext (sLit ">")] + text ">"] ppr (Breakpoint ix vars) = - hcat [ptext (sLit "break<"), + hcat [text "break<", ppr ix, - ptext (sLit ">"), + text ">", parens (hcat (punctuate comma (map ppr vars)))] ppr (ProfNote { profNoteCC = cc, profNoteCount = tick, profNoteScope = scope }) = case (tick,scope) of - (True,True) -> hcat [ptext (sLit "scctick<"), ppr cc, char '>'] - (True,False) -> hcat [ptext (sLit "tick<"), ppr cc, char '>'] - _ -> hcat [ptext (sLit "scc<"), ppr cc, char '>'] + (True,True) -> hcat [text "scctick<", ppr cc, char '>'] + (True,False) -> hcat [text "tick<", ppr cc, char '>'] + _ -> hcat [text "scc<", ppr cc, char '>'] ppr (SourceNote span _) = - hcat [ ptext (sLit "src<"), pprUserRealSpan True span, char '>'] + hcat [ text "src<", pprUserRealSpan True span, char '>'] {- ----------------------------------------------------- @@ -547,14 +547,14 @@ instance Outputable id => Outputable (Tickish id) where -} instance Outputable CoreVect where - ppr (Vect var e) = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=') + ppr (Vect var e) = hang (text "VECTORISE" <+> ppr var <+> char '=') 4 (pprCoreExpr e) - ppr (NoVect var) = ptext (sLit "NOVECTORISE") <+> ppr var - ppr (VectType False var Nothing) = ptext (sLit "VECTORISE type") <+> ppr var - ppr (VectType True var Nothing) = ptext (sLit "VECTORISE SCALAR type") <+> ppr var - ppr (VectType False var (Just tc)) = ptext (sLit "VECTORISE type") <+> ppr var <+> char '=' <+> + ppr (NoVect var) = text "NOVECTORISE" <+> ppr var + ppr (VectType False var Nothing) = text "VECTORISE type" <+> ppr var + ppr (VectType True var Nothing) = text "VECTORISE SCALAR type" <+> ppr var + ppr (VectType False var (Just tc)) = text "VECTORISE type" <+> ppr var <+> char '=' <+> ppr tc - ppr (VectType True var (Just tc)) = ptext (sLit "VECTORISE SCALAR type") <+> ppr var <+> + ppr (VectType True var (Just tc)) = text "VECTORISE SCALAR type" <+> ppr var <+> char '=' <+> ppr tc - ppr (VectClass tc) = ptext (sLit "VECTORISE class") <+> ppr tc - ppr (VectInst var) = ptext (sLit "VECTORISE SCALAR instance") <+> ppr var + ppr (VectClass tc) = text "VECTORISE class" <+> ppr tc + ppr (VectInst var) = text "VECTORISE SCALAR instance" <+> ppr var 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)..] ] -- ---------------------------------------------------------------------------- diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs index 985bec4429..f1f6f70e57 100644 --- a/compiler/ghci/ByteCodeInstr.hs +++ b/compiler/ghci/ByteCodeInstr.hs @@ -167,21 +167,21 @@ pprCoreExprShort expr@(Lam _ _) = let (bndrs, _) = collectBinders expr in - char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> ptext (sLit "...") + char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> text "..." pprCoreExprShort (Case _expr var _ty _alts) - = ptext (sLit "case of") <+> ppr var + = text "case of" <+> ppr var -pprCoreExprShort (Let (NonRec x _) _) = ptext (sLit "let") <+> ppr x <+> ptext (sLit ("= ... in ...")) -pprCoreExprShort (Let (Rec bs) _) = ptext (sLit "let {") <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ...")) +pprCoreExprShort (Let (NonRec x _) _) = text "let" <+> ppr x <+> ptext (sLit ("= ... in ...")) +pprCoreExprShort (Let (Rec bs) _) = text "let {" <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ...")) pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e -pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> ptext (sLit "`cast` T") +pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> text "`cast` T" pprCoreExprShort e = pprCoreExpr e pprCoreAltShort :: CoreAlt -> SDoc -pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> ptext (sLit "->") <+> pprCoreExprShort expr +pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr instance Outputable BCInstr where ppr (STKCHECK n) = text "STKCHECK" <+> ppr n diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs index 44d272ec23..982b4fc148 100644 --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -546,22 +546,22 @@ normalObjectSuffix = phaseInputExt StopLn failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath) failNonStd dflags srcspan = dieWith dflags srcspan $ - ptext (sLit "Cannot load") <+> compWay <+> - ptext (sLit "objects when GHC is built") <+> ghciWay $$ - ptext (sLit "To fix this, either:") $$ - ptext (sLit " (1) Use -fexternal-interprter, or") $$ - ptext (sLit " (2) Build the program twice: once") <+> - ghciWay <> ptext (sLit ", and then") $$ - ptext (sLit " with") <+> compWay <+> - ptext (sLit "using -osuf to set a different object file suffix.") + text "Cannot load" <+> compWay <+> + text "objects when GHC is built" <+> ghciWay $$ + text "To fix this, either:" $$ + text " (1) Use -fexternal-interprter, or" $$ + text " (2) Build the program twice: once" <+> + ghciWay <> text ", and then" $$ + text " with" <+> compWay <+> + text "using -osuf to set a different object file suffix." where compWay - | WayDyn `elem` ways dflags = ptext (sLit "-dynamic") - | WayProf `elem` ways dflags = ptext (sLit "-prof") - | otherwise = ptext (sLit "normal") + | WayDyn `elem` ways dflags = text "-dynamic" + | WayProf `elem` ways dflags = text "-prof" + | otherwise = text "normal" ghciWay - | dynamicGhc = ptext (sLit "with -dynamic") - | rtsIsProfiled = ptext (sLit "with -prof") - | otherwise = ptext (sLit "the normal way") + | dynamicGhc = text "with -dynamic" + | rtsIsProfiled = text "with -prof" + | otherwise = text "the normal way" getLinkDeps :: HscEnv -> HomePackageTable -> PersistentLinkerState @@ -649,11 +649,11 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods no_obj :: Outputable a => a -> IO b no_obj mod = dieWith dflags span $ - ptext (sLit "cannot find object file for module ") <> + text "cannot find object file for module " <> quotes (ppr mod) $$ while_linking_expr - while_linking_expr = ptext (sLit "while linking an interpreted expression") + while_linking_expr = text "while linking an interpreted expression" -- This one is a build-system bug @@ -691,7 +691,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods ok <- doesFileExist new_file if (not ok) then dieWith dflags span $ - ptext (sLit "cannot find object file ") + text "cannot find object file " <> quotes (text new_file) $$ while_linking_expr else return (DotO new_file) adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp) diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index c76fc3a5c5..5b0b1a4125 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -124,7 +124,7 @@ wrapMsg what item (CvtM m) where -- Show the item in pretty syntax normally, -- but with all its constructors if you say -dppr-debug - msg sty = hang (ptext (sLit "When splicing a TH") <+> text what <> colon) + msg sty = hang (text "When splicing a TH" <+> text what <> colon) 2 (if debugStyle sty then text (show item) else text (pprint item)) @@ -148,7 +148,7 @@ cvtDec (TH.ValD pat body ds) | otherwise = do { pat' <- cvtPat pat ; body' <- cvtGuard body - ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) ds + ; ds' <- cvtLocalDecs (text "a where clause") ds ; returnJustL $ Hs.ValD $ PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds') , pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames @@ -156,9 +156,9 @@ cvtDec (TH.ValD pat body ds) cvtDec (TH.FunD nm cls) | null cls - = failWith (ptext (sLit "Function binding for") + = failWith (text "Function binding for" <+> quotes (text (TH.pprint nm)) - <+> ptext (sLit "has no equations")) + <+> text "has no equations") | otherwise = do { nm' <- vNameL nm ; cls' <- mapM cvtClause cls @@ -229,7 +229,7 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) cvtDec (ClassD ctxt cl tvs fds decs) = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs ; fds' <- mapM cvt_fundep fds - ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs + ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (text "a class declaration") decs ; unless (null adts') (failWith $ (text "Default data instance declarations" <+> text "are not allowed:") @@ -251,7 +251,7 @@ cvtDec (ClassD ctxt cl tvs fds decs) Left (_, msg) -> failWith msg cvtDec (InstanceD ctxt ty decs) - = do { let doc = ptext (sLit "an instance declaration") + = do { let doc = text "an instance declaration" ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs ; unless (null fams') (failWith (mkBadDecMsg doc fams')) ; ctxt' <- cvtContext ctxt @@ -429,7 +429,7 @@ is_bind decl = Right decl mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc mkBadDecMsg doc bads - = sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon + = sep [ text "Illegal declaration(s) in" <+> doc <> colon , nest 2 (vcat (map Outputable.ppr bads)) ] --------------------------------------------------- @@ -552,7 +552,7 @@ cvtForD (ImportF callconv safety from nm ty) from (noLoc from) = mk_imp impspec | otherwise - = failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent") + = failWith $ text (show from) <+> text "is not a valid ccall impent" where mk_imp impspec = do { nm' <- vNameL nm @@ -695,7 +695,7 @@ cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) cvtClause (Clause ps body wheres) = do { ps' <- cvtPats ps ; g' <- cvtGuard body - ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres + ; ds' <- cvtLocalDecs (text "a where clause") wheres ; returnL $ Hs.Match NonFunBindMatch ps' Nothing (GRHSs g' (noLoc ds')) } @@ -734,10 +734,10 @@ cvtl e = wrapL (cvt e) cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; ; return $ HsIf (Just noSyntaxExpr) x' y' z' } cvt (MultiIfE alts) - | null alts = failWith (ptext (sLit "Multi-way if-expression with no alternatives")) + | null alts = failWith (text "Multi-way if-expression with no alternatives") | otherwise = do { alts' <- mapM cvtpair alts ; return $ HsMultiIf placeHolderType alts' } - cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds + cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds ; e' <- cvtl e; return $ HsLet (noLoc ds') e' } cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM cvtMatch ms ; return $ HsCase e' (mkMatchGroup FromSource ms') } @@ -885,7 +885,7 @@ cvtOpApp x op y cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName) cvtHsDo do_or_lc stmts - | null stmts = failWith (ptext (sLit "Empty stmt list in do-block")) + | null stmts = failWith (text "Empty stmt list in do-block") | otherwise = do { stmts' <- cvtStmts stmts ; let Just (stmts'', last') = snocView stmts' @@ -896,9 +896,9 @@ cvtHsDo do_or_lc stmts ; return $ HsDo do_or_lc (noLoc (stmts'' ++ [last''])) placeHolderType } where - bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon + bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon , nest 2 $ Outputable.ppr stmt - , ptext (sLit "(It should be an expression.)") ] + , text "(It should be an expression.)" ] cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName (LHsExpr RdrName)] cvtStmts = mapM cvtStmt @@ -906,7 +906,7 @@ cvtStmts = mapM cvtStmt cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName (LHsExpr RdrName)) cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' } cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } -cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds +cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds ; returnL $ LetStmt (noLoc ds') } cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr } where @@ -916,7 +916,7 @@ cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) cvtMatch (TH.Match p body decs) = do { p' <- cvtPat p ; g' <- cvtGuard body - ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs + ; decs' <- cvtLocalDecs (text "a where clause") decs ; returnL $ Hs.Match NonFunBindMatch [p'] Nothing (GRHSs g' (noLoc decs')) } @@ -1343,8 +1343,8 @@ isVarName (TH.Name occ _) badOcc :: OccName.NameSpace -> String -> SDoc badOcc ctxt_ns occ - = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns - <+> ptext (sLit "name:") <+> quotes (text occ) + = text "Illegal" <+> pprNameSpace ctxt_ns + <+> text "name:" <+> quotes (text occ) thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName -- This turns a TH Name into a RdrName; used for both binders and occurrences diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index 3f502c9824..c130f4d4f3 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -445,8 +445,8 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR id pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs) where ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds - pp_rec Recursive = ptext (sLit "rec") - pp_rec NonRecursive = ptext (sLit "nonrec") + pp_rec Recursive = text "rec" + pp_rec NonRecursive = text "nonrec" pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc pprLHsBinds binds @@ -566,15 +566,15 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars = sdocWithDynFlags $ \ dflags -> if gopt Opt_PrintTypecheckerElaboration dflags then -- Show extra information (bug number: #10662) - hang (ptext (sLit "AbsBinds") <+> brackets (interpp'SP tyvars) + hang (text "AbsBinds" <+> brackets (interpp'SP tyvars) <+> brackets (interpp'SP dictvars)) 2 $ braces $ vcat - [ ptext (sLit "Exports:") <+> + [ text "Exports:" <+> brackets (sep (punctuate comma (map ppr exports))) - , ptext (sLit "Exported types:") <+> + , text "Exported types:" <+> vcat [pprBndr LetBind (abe_poly ex) | ex <- exports] - , ptext (sLit "Binds:") <+> pprLHsBinds val_binds - , ptext (sLit "Evidence:") <+> ppr ev_binds ] + , text "Binds:" <+> pprLHsBinds val_binds + , text "Evidence:" <+> ppr ev_binds ] else pprLHsBinds val_binds ppr_monobind (AbsBindsSig { abs_tvs = tyvars @@ -594,7 +594,7 @@ ppr_monobind (AbsBindsSig { abs_tvs = tyvars instance (OutputableBndr id) => Outputable (ABExport id) where ppr (ABE { abe_wrap = wrap, abe_inst_wrap = inst_wrap , abe_poly = gbl, abe_mono = lcl, abe_prags = prags }) - = vcat [ ppr gbl <+> ptext (sLit "<=") <+> ppr lcl + = vcat [ ppr gbl <+> text "<=" <+> ppr lcl , nest 2 (pprTcSpecPrags prags) , nest 2 (ppr wrap) , nest 2 (ppr inst_wrap)] @@ -603,7 +603,7 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL ppr (PSB{ psb_id = L _ psyn, psb_args = details, psb_def = pat, psb_dir = dir }) = ppr_lhs <+> ppr_rhs where - ppr_lhs = ptext (sLit "pattern") <+> ppr_details + ppr_lhs = text "pattern" <+> ppr_details ppr_simple syntax = syntax <+> ppr pat ppr_details = case details of @@ -614,9 +614,9 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL <> braces (sep (punctuate comma (map ppr vs))) ppr_rhs = case dir of - Unidirectional -> ppr_simple (ptext (sLit "<-")) + Unidirectional -> ppr_simple (text "<-") ImplicitBidirectional -> ppr_simple equals - ExplicitBidirectional mg -> ppr_simple (ptext (sLit "<-")) <+> ptext (sLit "where") $$ + ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$ (nest 2 $ pprFunBind psyn mg) pprTicks :: SDoc -> SDoc -> SDoc @@ -888,17 +888,17 @@ isMinimalLSig (L _ (MinimalSig {})) = True isMinimalLSig _ = False hsSigDoc :: Sig name -> SDoc -hsSigDoc (TypeSig {}) = ptext (sLit "type signature") -hsSigDoc (PatSynSig {}) = ptext (sLit "pattern synonym signature") +hsSigDoc (TypeSig {}) = text "type signature" +hsSigDoc (PatSynSig {}) = text "pattern synonym signature" hsSigDoc (ClassOpSig is_deflt _ _) - | is_deflt = ptext (sLit "default type signature") - | otherwise = ptext (sLit "class method signature") -hsSigDoc (IdSig {}) = ptext (sLit "id signature") -hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma") -hsSigDoc (InlineSig _ prag) = ppr (inlinePragmaSpec prag) <+> ptext (sLit "pragma") -hsSigDoc (SpecInstSig {}) = ptext (sLit "SPECIALISE instance pragma") -hsSigDoc (FixSig {}) = ptext (sLit "fixity declaration") -hsSigDoc (MinimalSig {}) = ptext (sLit "MINIMAL pragma") + | is_deflt = text "default type signature" + | otherwise = text "class method signature" +hsSigDoc (IdSig {}) = text "id signature" +hsSigDoc (SpecSig {}) = text "SPECIALISE pragma" +hsSigDoc (InlineSig _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma" +hsSigDoc (SpecInstSig {}) = text "SPECIALISE instance pragma" +hsSigDoc (FixSig {}) = text "fixity declaration" +hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" {- Check if signatures overlap; this is used when checking for duplicate @@ -912,7 +912,7 @@ instance (OutputableBndr name) => Outputable (Sig name) where ppr_sig :: OutputableBndr name => Sig name -> SDoc ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (ClassOpSig is_deflt vars ty) - | is_deflt = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty) + | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) | otherwise = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id)) ppr_sig (FixSig fix_sig) = ppr fix_sig @@ -920,16 +920,16 @@ ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl) ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var)) ppr_sig (SpecInstSig _ ty) - = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty) + = pragBrackets (text "SPECIALIZE instance" <+> ppr ty) ppr_sig (MinimalSig _ bf) = pragBrackets (pprMinimalSig bf) ppr_sig (PatSynSig name sig_ty) - = ptext (sLit "pattern") <+> pprPrefixOcc (unLoc name) <+> dcolon + = text "pattern" <+> pprPrefixOcc (unLoc name) <+> dcolon <+> ppr sig_ty pprPatSynSig :: (OutputableBndr name) => name -> Bool -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc -> SDoc pprPatSynSig ident _is_bidir tvs req prov ty - = ptext (sLit "pattern") <+> pprPrefixOcc ident <+> dcolon <+> + = text "pattern" <+> pprPrefixOcc ident <+> dcolon <+> tvs <+> context <+> ty where context = case (req, prov) of @@ -944,7 +944,7 @@ instance OutputableBndr name => Outputable (FixitySig name) where pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names) pragBrackets :: SDoc -> SDoc -pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}") +pragBrackets doc = text "{-#" <+> doc <+> ptext (sLit "#-}") pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty] @@ -952,20 +952,20 @@ pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty] pprvars = hsep $ punctuate comma (map pprPrefixOcc vars) pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc -pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig [var] pp_ty +pprSpec var pp_ty inl = text "SPECIALIZE" <+> pp_inl <+> pprVarSig [var] pp_ty where pp_inl | isDefaultInlinePragma inl = empty | otherwise = ppr inl pprTcSpecPrags :: TcSpecPrags -> SDoc -pprTcSpecPrags IsDefaultMethod = ptext (sLit "<default method>") +pprTcSpecPrags IsDefaultMethod = text "<default method>" pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps) instance Outputable TcSpecPrag where - ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "<type>")) inl + ppr (SpecPrag var _ inl) = pprSpec var (text "<type>") inl pprMinimalSig :: OutputableBndr name => LBooleanFormula (Located name) -> SDoc -pprMinimalSig (L _ bf) = ptext (sLit "MINIMAL") <+> ppr (fmap unLoc bf) +pprMinimalSig (L _ bf) = text "MINIMAL" <+> ppr (fmap unLoc bf) {- ************************************************************************ diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index a1f24b457a..75544abf5c 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -104,7 +104,6 @@ import Class import Outputable import Util import SrcLoc -import FastString import Bag import Data.Maybe ( fromMaybe ) @@ -652,7 +651,7 @@ instance OutputableBndr name ppr (FamDecl { tcdFam = decl }) = ppr decl ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdRhs = rhs }) - = hang (ptext (sLit "type") <+> + = hang (text "type" <+> pp_vanilla_decl_head ltycon tyvars [] <+> equals) 4 (ppr rhs) @@ -667,12 +666,12 @@ instance OutputableBndr name = top_matter | otherwise -- Laid out - = vcat [ top_matter <+> ptext (sLit "where") + = vcat [ top_matter <+> text "where" , nest 2 $ pprDeclList (map (pprFamilyDecl NotTopLevel . unLoc) ats ++ map ppr_fam_deflt_eqn at_defs ++ pprLHsBindsForUser methods sigs) ] where - top_matter = ptext (sLit "class") + top_matter = text "class" <+> pp_vanilla_decl_head lclas tyvars (unLoc context) <+> pprFundeps (map unLoc fds) @@ -690,8 +689,8 @@ pp_vanilla_decl_head thing tyvars context = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars] pprTyClDeclFlavour :: TyClDecl a -> SDoc -pprTyClDeclFlavour (ClassDecl {}) = ptext (sLit "class") -pprTyClDeclFlavour (SynDecl {}) = ptext (sLit "type") +pprTyClDeclFlavour (ClassDecl {}) = text "class" +pprTyClDeclFlavour (SynDecl {}) = text "type" pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) = pprFlavour info <+> text "family" pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) @@ -909,16 +908,16 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon Nothing -> empty (pp_where, pp_eqns) = case info of ClosedTypeFamily mb_eqns -> - ( ptext (sLit "where") + ( text "where" , case mb_eqns of - Nothing -> ptext (sLit "..") + Nothing -> text ".." Just eqns -> vcat $ map ppr_fam_inst_eqn eqns ) _ -> (empty, empty) pprFlavour :: FamilyInfo name -> SDoc -pprFlavour DataFamily = ptext (sLit "data") -pprFlavour OpenTypeFamily = ptext (sLit "type") -pprFlavour (ClosedTypeFamily {}) = ptext (sLit "type") +pprFlavour DataFamily = text "data" +pprFlavour OpenTypeFamily = text "type" +pprFlavour (ClosedTypeFamily {}) = text "type" instance Outputable (FamilyInfo name) where ppr info = pprFlavour info <+> text "family" @@ -1100,21 +1099,21 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context Just kind -> dcolon <+> ppr kind pp_derivings = case derivings of Nothing -> empty - Just (L _ ds) -> hsep [ ptext (sLit "deriving") + Just (L _ ds) -> hsep [ text "deriving" , parens (interpp'SP ds)] instance OutputableBndr name => Outputable (HsDataDefn name) where - ppr d = pp_data_defn (\_ -> ptext (sLit "Naked HsDataDefn")) d + ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d instance Outputable NewOrData where - ppr NewType = ptext (sLit "newtype") - ppr DataType = ptext (sLit "data") + ppr NewType = text "newtype" + ppr DataType = text "data" pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax - = hang (ptext (sLit "where")) 2 (vcat (map ppr cs)) + = hang (text "where") 2 (vcat (map ppr cs)) pp_condecls cs -- In H98 syntax - = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs)) + = equals <+> sep (punctuate (text " |") (map ppr cs)) instance (OutputableBndr name) => Outputable (ConDecl name) where ppr = pprConDecl @@ -1311,10 +1310,10 @@ instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where pprTyFamInstDecl :: OutputableBndr name => TopLevelFlag -> TyFamInstDecl name -> SDoc pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) - = ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn + = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn ppr_instance_keyword :: TopLevelFlag -> SDoc -ppr_instance_keyword TopLevel = ptext (sLit "instance") +ppr_instance_keyword TopLevel = text "instance" ppr_instance_keyword NotTopLevel = empty ppr_fam_inst_eqn :: OutputableBndr name => LTyFamInstEqn name -> SDoc @@ -1362,24 +1361,24 @@ instance (OutputableBndr name) => Outputable (ClsInstDecl name) where = top_matter | otherwise -- Laid out - = vcat [ top_matter <+> ptext (sLit "where") + = vcat [ top_matter <+> text "where" , nest 2 $ pprDeclList $ map (pprTyFamInstDecl NotTopLevel . unLoc) ats ++ map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++ pprLHsBindsForUser binds sigs ] where - top_matter = ptext (sLit "instance") <+> ppOverlapPragma mbOverlap + top_matter = text "instance" <+> ppOverlapPragma mbOverlap <+> ppr inst_ty ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc ppOverlapPragma mb = case mb of Nothing -> empty - Just (L _ (NoOverlap _)) -> ptext (sLit "{-# NO_OVERLAP #-}") - Just (L _ (Overlappable _)) -> ptext (sLit "{-# OVERLAPPABLE #-}") - Just (L _ (Overlapping _)) -> ptext (sLit "{-# OVERLAPPING #-}") - Just (L _ (Overlaps _)) -> ptext (sLit "{-# OVERLAPS #-}") - Just (L _ (Incoherent _)) -> ptext (sLit "{-# INCOHERENT #-}") + Just (L _ (NoOverlap _)) -> text "{-# NO_OVERLAP #-}" + Just (L _ (Overlappable _)) -> text "{-# OVERLAPPABLE #-}" + Just (L _ (Overlapping _)) -> text "{-# OVERLAPPING #-}" + Just (L _ (Overlaps _)) -> text "{-# OVERLAPS #-}" + Just (L _ (Incoherent _)) -> text "{-# INCOHERENT #-}" instance (OutputableBndr name) => Outputable (InstDecl name) where @@ -1423,7 +1422,7 @@ deriving instance (DataId name) => Data (DerivDecl name) instance (OutputableBndr name) => Outputable (DerivDecl name) where ppr (DerivDecl ty o) - = hsep [ptext (sLit "deriving instance"), ppOverlapPragma o, ppr ty] + = hsep [text "deriving instance", ppOverlapPragma o, ppr ty] {- ************************************************************************ @@ -1452,7 +1451,7 @@ instance (OutputableBndr name) => Outputable (DefaultDecl name) where ppr (DefaultDecl tys) - = ptext (sLit "default") <+> parens (interpp'SP tys) + = text "default" <+> parens (interpp'SP tys) {- ************************************************************************ @@ -1553,10 +1552,10 @@ data ForeignExport = CExport (Located CExportSpec) -- contains the calling instance OutputableBndr name => Outputable (ForeignDecl name) where ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport }) - = hang (ptext (sLit "foreign import") <+> ppr fimport <+> ppr n) + = hang (text "foreign import" <+> ppr fimport <+> ppr n) 2 (dcolon <+> ppr ty) ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) = - hang (ptext (sLit "foreign export") <+> ppr fexport <+> ppr n) + hang (text "foreign export" <+> ppr fexport <+> ppr n) 2 (dcolon <+> ppr ty) instance Outputable ForeignImport where @@ -1569,15 +1568,15 @@ instance Outputable ForeignImport where Just (Header _ header) -> ftext header pprCEntity (CLabel lbl) = - ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl + text "static" <+> pp_hdr <+> char '&' <> ppr lbl pprCEntity (CFunction (StaticTarget _ lbl _ isFun)) = - ptext (sLit "static") + text "static" <+> pp_hdr - <+> (if isFun then empty else ptext (sLit "value")) + <+> (if isFun then empty else text "value") <+> ppr lbl pprCEntity (CFunction (DynamicTarget)) = - ptext (sLit "dynamic") - pprCEntity (CWrapper) = ptext (sLit "wrapper") + text "dynamic" + pprCEntity (CWrapper) = text "wrapper" instance Outputable ForeignExport where ppr (CExport (L _ (CExportStatic _ lbl cconv)) _) = @@ -1874,11 +1873,11 @@ annProvenanceName_maybe (TypeAnnProvenance (L _ name)) = Just name annProvenanceName_maybe ModuleAnnProvenance = Nothing pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc -pprAnnProvenance ModuleAnnProvenance = ptext (sLit "ANN module") +pprAnnProvenance ModuleAnnProvenance = text "ANN module" pprAnnProvenance (ValueAnnProvenance (L _ name)) - = ptext (sLit "ANN") <+> ppr name + = text "ANN" <+> ppr name pprAnnProvenance (TypeAnnProvenance (L _ name)) - = ptext (sLit "ANN type") <+> ppr name + = text "ANN type" <+> ppr name {- ************************************************************************ @@ -1903,7 +1902,7 @@ data RoleAnnotDecl name instance OutputableBndr name => Outputable (RoleAnnotDecl name) where ppr (RoleAnnotDecl ltycon roles) - = ptext (sLit "type role") <+> ppr ltycon <+> + = text "type role" <+> ppr ltycon <+> hsep (map (pp_role . unLoc) roles) where pp_role Nothing = underscore diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 6b395a318a..62b6a680e9 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -647,7 +647,7 @@ ppr_expr (HsOverLit lit) = ppr lit ppr_expr (HsPar e) = parens (ppr_lexpr e) ppr_expr (HsCoreAnn _ (StringLiteral _ s) e) - = vcat [ptext (sLit "HsCoreAnn") <+> ftext s, ppr_lexpr e] + = vcat [text "HsCoreAnn" <+> ftext s, ppr_lexpr e] ppr_expr (HsApp e1 e2) = let (fun, args) = collect_args e1 [e2] in @@ -681,7 +681,7 @@ ppr_expr (SectionL expr op) pp_expr = pprDebugParendExpr expr pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) - 4 (hsep [pp_expr, ptext (sLit "x_ )")]) + 4 (hsep [pp_expr, text "x_ )"]) pp_infixly v = (sep [pp_expr, pprInfixOcc v]) ppr_expr (SectionR op expr) @@ -691,7 +691,7 @@ ppr_expr (SectionR op expr) where pp_expr = pprDebugParendExpr expr - pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")]) + pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) 4 (pp_expr <> rparen) pp_infixly v = sep [pprInfixOcc v, pp_expr] @@ -710,33 +710,33 @@ ppr_expr (HsLam matches) = pprMatches (LambdaExpr :: HsMatchContext id) matches ppr_expr (HsLamCase _ matches) - = sep [ sep [ptext (sLit "\\case {")], + = sep [ sep [text "\\case {"], nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ] ppr_expr (HsCase expr matches) - = sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")], + = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")], nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ] ppr_expr (HsIf _ e1 e2 e3) - = sep [hsep [ptext (sLit "if"), nest 2 (ppr e1), ptext (sLit "then")], + = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")], nest 4 (ppr e2), - ptext (sLit "else"), + text "else", nest 4 (ppr e3)] ppr_expr (HsMultiIf _ alts) - = sep $ ptext (sLit "if") : map ppr_alt alts + = sep $ text "if" : map ppr_alt alts where ppr_alt (L _ (GRHS guards expr)) = sep [ vbar <+> interpp'SP guards - , ptext (sLit "->") <+> pprDeeper (ppr expr) ] + , text "->" <+> pprDeeper (ppr expr) ] -- special case: let ... in let ... ppr_expr (HsLet (L _ binds) expr@(L _ (HsLet _ _))) - = sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]), + = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), ppr_lexpr expr] ppr_expr (HsLet (L _ binds) expr) - = sep [hang (ptext (sLit "let")) 2 (pprBinds binds), - hang (ptext (sLit "in")) 2 (ppr expr)] + = sep [hang (text "let") 2 (pprBinds binds), + hang (text "in") 2 (ppr expr)] ppr_expr (HsDo do_or_list_comp (L _ stmts) _) = pprDo do_or_list_comp stmts @@ -765,10 +765,10 @@ ppr_expr (PArrSeq _ info) = paBrackets (ppr info) ppr_expr EWildPat = char '_' ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e -ppr_expr (EViewPat p e) = ppr p <+> ptext (sLit "->") <+> ppr e +ppr_expr (EViewPat p e) = ppr p <+> text "->" <+> ppr e ppr_expr (HsSCC _ (StringLiteral _ lbl) expr) - = sep [ ptext (sLit "{-# SCC") <+> doubleQuotes (ftext lbl) <+> ptext (sLit "#-}"), + = sep [ text "{-# SCC" <+> doubleQuotes (ftext lbl) <+> ptext (sLit "#-}"), pprParendExpr expr ] ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn @@ -780,34 +780,34 @@ ppr_expr (HsTypeOut (HsWC { hswc_body = ty })) ppr_expr (HsSpliceE s) = pprSplice s ppr_expr (HsBracket b) = pprHsBracket b ppr_expr (HsRnBracketOut e []) = ppr e -ppr_expr (HsRnBracketOut e ps) = ppr e $$ ptext (sLit "pending(rn)") <+> ppr ps +ppr_expr (HsRnBracketOut e ps) = ppr e $$ text "pending(rn)" <+> ppr ps ppr_expr (HsTcBracketOut e []) = ppr e -ppr_expr (HsTcBracketOut e ps) = ppr e $$ ptext (sLit "pending(tc)") <+> ppr ps +ppr_expr (HsTcBracketOut e ps) = ppr e $$ text "pending(tc)" <+> ppr ps ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _))) - = hsep [ptext (sLit "proc"), ppr pat, ptext (sLit "->"), ppr cmd] + = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd] ppr_expr (HsStatic e) - = hsep [ptext (sLit "static"), pprParendExpr e] + = hsep [text "static", pprParendExpr e] ppr_expr (HsTick tickish exp) = pprTicks (ppr exp) $ ppr tickish <+> ppr_lexpr exp ppr_expr (HsBinTick tickIdTrue tickIdFalse exp) = pprTicks (ppr exp) $ - hcat [ptext (sLit "bintick<"), + hcat [text "bintick<", ppr tickIdTrue, - ptext (sLit ","), + text ",", ppr tickIdFalse, - ptext (sLit ">("), - ppr exp,ptext (sLit ")")] + text ">(", + ppr exp, text ")"] ppr_expr (HsTickPragma _ externalSrcLoc _ exp) = pprTicks (ppr exp) $ - hcat [ptext (sLit "tickpragma<"), + hcat [text "tickpragma<", pprExternalSrcLoc externalSrcLoc, - ptext (sLit ">("), + text ">(", ppr exp, - ptext (sLit ")")] + text ")"] ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True) = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] @@ -821,8 +821,8 @@ ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False) ppr_expr (HsArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2]) = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] ppr_expr (HsArrForm op _ args) - = hang (ptext (sLit "(|") <+> ppr_lexpr op) - 4 (sep (map (pprCmdArg.unLoc) args) <+> ptext (sLit "|)")) + = hang (text "(|" <+> ppr_lexpr op) + 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)") ppr_expr (HsRecFld f) = ppr f pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc @@ -1051,23 +1051,23 @@ ppr_cmd (HsCmdLam matches) = pprMatches (LambdaExpr :: HsMatchContext id) matches ppr_cmd (HsCmdCase expr matches) - = sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")], + = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")], nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ] ppr_cmd (HsCmdIf _ e ct ce) - = sep [hsep [ptext (sLit "if"), nest 2 (ppr e), ptext (sLit "then")], + = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")], nest 4 (ppr ct), - ptext (sLit "else"), + text "else", nest 4 (ppr ce)] -- special case: let ... in let ... ppr_cmd (HsCmdLet (L _ binds) cmd@(L _ (HsCmdLet _ _))) - = sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]), + = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), ppr_lcmd cmd] ppr_cmd (HsCmdLet (L _ binds) cmd) - = sep [hang (ptext (sLit "let")) 2 (pprBinds binds), - hang (ptext (sLit "in")) 2 (ppr cmd)] + = sep [hang (text "let") 2 (pprBinds binds), + hang (text "in") 2 (ppr cmd)] ppr_cmd (HsCmdDo (L _ stmts) _) = pprDo ArrowExpr stmts @@ -1085,8 +1085,8 @@ ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False) ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2]) = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] ppr_cmd (HsCmdArrForm op _ args) - = hang (ptext (sLit "(|") <> ppr_lexpr op) - 4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)")) + = hang (text "(|" <> ppr_lexpr op) + 4 (sep (map (pprCmdArg.unLoc) args) <> text "|)") pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc pprCmdArg (HsCmdTop cmd@(L _ (HsCmdArrForm _ Nothing [])) _ _ _) @@ -1635,23 +1635,23 @@ instance (OutputableBndr idL, OutputableBndr idR, Outputable body) pprStmt :: forall idL idR body . (OutputableBndr idL, OutputableBndr idR, Outputable body) => (StmtLR idL idR body) -> SDoc pprStmt (LastStmt expr ret_stripped _) - = ifPprDebug (ptext (sLit "[last]")) <+> - (if ret_stripped then ptext (sLit "return") else empty) <+> + = ifPprDebug (text "[last]") <+> + (if ret_stripped then text "return" else empty) <+> ppr expr pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, larrow, ppr expr] -pprStmt (LetStmt (L _ binds)) = hsep [ptext (sLit "let"), pprBinds binds] +pprStmt (LetStmt (L _ binds)) = hsep [text "let", pprBinds binds] pprStmt (BodyStmt expr _ _ _) = ppr expr -pprStmt (ParStmt stmtss _ _) = sep (punctuate (ptext (sLit " | ")) (map ppr stmtss)) +pprStmt (ParStmt stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss)) pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form }) = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form]) pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids , recS_later_ids = later_ids }) - = ptext (sLit "rec") <+> + = text "rec" <+> vcat [ ppr_do_stmts segment - , ifPprDebug (vcat [ ptext (sLit "rec_ids=") <> ppr rec_ids - , ptext (sLit "later_ids=") <> ppr later_ids])] + , ifPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids + , text "later_ids=" <> ppr later_ids])] pprStmt (ApplicativeStmt args mb_join _) = getPprStyle $ \style -> @@ -1678,43 +1678,43 @@ pprStmt (ApplicativeStmt args mb_join _) pp_debug = let - ap_expr = sep (punctuate (ptext (sLit " |")) (map pp_arg args)) + ap_expr = sep (punctuate (text " |") (map pp_arg args)) in if isNothing mb_join then ap_expr - else ptext (sLit "join") <+> parens ap_expr + else text "join" <+> parens ap_expr pp_arg (_, ApplicativeArgOne pat expr) = ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr :: ExprStmt idL) pp_arg (_, ApplicativeArgMany stmts return pat) = ppr pat <+> - ptext (sLit "<-") <+> + text "<-" <+> ppr (HsDo DoExpr (noLoc (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)])) (error "pprStmt")) pprTransformStmt :: OutputableBndr id => [id] -> LHsExpr id -> Maybe (LHsExpr id) -> SDoc pprTransformStmt bndrs using by - = sep [ ptext (sLit "then") <+> ifPprDebug (braces (ppr bndrs)) + = sep [ text "then" <+> ifPprDebug (braces (ppr bndrs)) , nest 2 (ppr using) , nest 2 (pprBy by)] pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc pprTransStmt by using ThenForm - = sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)] + = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)] pprTransStmt by using GroupForm - = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)] + = sep [ text "then group", nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)] pprBy :: Outputable body => Maybe body -> SDoc pprBy Nothing = empty -pprBy (Just e) = ptext (sLit "by") <+> ppr e +pprBy (Just e) = text "by" <+> ppr e pprDo :: (OutputableBndr id, Outputable body) => HsStmtContext any -> [LStmt id body] -> SDoc -pprDo DoExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts -pprDo GhciStmtCtxt stmts = ptext (sLit "do") <+> ppr_do_stmts stmts -pprDo ArrowExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts -pprDo MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts +pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts +pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts +pprDo ArrowExpr stmts = text "do" <+> ppr_do_stmts stmts +pprDo MDoExpr stmts = text "mdo" <+> ppr_do_stmts stmts pprDo ListComp stmts = brackets $ pprComp stmts pprDo PArrComp stmts = paBrackets $ pprComp stmts pprDo MonadComp stmts = brackets $ pprComp stmts @@ -1862,14 +1862,14 @@ pprPendingSplice :: OutputableBndr id => SplicePointName -> LHsExpr id -> SDoc pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e) pprSplice :: OutputableBndr id => HsSplice id -> SDoc -pprSplice (HsTypedSplice n e) = ppr_splice (ptext (sLit "$$")) n e -pprSplice (HsUntypedSplice n e) = ppr_splice (ptext (sLit "$")) n e +pprSplice (HsTypedSplice n e) = ppr_splice (text "$$") n e +pprSplice (HsUntypedSplice n e) = ppr_splice (text "$") n e pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s ppr_quasi :: OutputableBndr id => id -> id -> FastString -> SDoc ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <> char '[' <> ppr quoter <> vbar <> - ppr quote <> ptext (sLit "|]") + ppr quote <> text "|]" ppr_splice :: OutputableBndr id => SDoc -> id -> LHsExpr id -> SDoc ppr_splice herald n e @@ -1910,15 +1910,15 @@ pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp) pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds)) pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) pprHsBracket (VarBr True n) = char '\'' <> ppr n -pprHsBracket (VarBr False n) = ptext (sLit "''") <> ppr n +pprHsBracket (VarBr False n) = text "''" <> ppr n pprHsBracket (TExpBr e) = thTyBrackets (ppr e) thBrackets :: SDoc -> SDoc -> SDoc thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+> - pp_body <+> ptext (sLit "|]") + pp_body <+> text "|]" thTyBrackets :: SDoc -> SDoc -thTyBrackets pp_body = ptext (sLit "[||") <+> pp_body <+> ptext (sLit "||]") +thTyBrackets pp_body = text "[||" <+> pp_body <+> ptext (sLit "||]") instance Outputable PendingRnSplice where ppr (PendingRnSplice _ n e) = pprPendingSplice n e @@ -1954,7 +1954,7 @@ instance OutputableBndr id => Outputable (ArithSeqInfo id) where = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3] pp_dotdot :: SDoc -pp_dotdot = ptext (sLit " .. ") +pp_dotdot = text " .. " {- ************************************************************************ @@ -2015,13 +2015,13 @@ isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt isMonadCompExpr _ = False matchSeparator :: HsMatchContext id -> SDoc -matchSeparator (FunRhs {}) = ptext (sLit "=") -matchSeparator CaseAlt = ptext (sLit "->") -matchSeparator IfAlt = ptext (sLit "->") -matchSeparator LambdaExpr = ptext (sLit "->") -matchSeparator ProcExpr = ptext (sLit "->") -matchSeparator PatBindRhs = ptext (sLit "=") -matchSeparator (StmtCtxt _) = ptext (sLit "<-") +matchSeparator (FunRhs {}) = text "=" +matchSeparator CaseAlt = text "->" +matchSeparator IfAlt = text "->" +matchSeparator LambdaExpr = text "->" +matchSeparator ProcExpr = text "->" +matchSeparator PatBindRhs = text "=" +matchSeparator (StmtCtxt _) = text "<-" matchSeparator RecUpd = panic "unused" matchSeparator ThPatSplice = panic "unused" matchSeparator ThPatQuote = panic "unused" @@ -2029,34 +2029,34 @@ matchSeparator PatSyn = panic "unused" pprMatchContext :: Outputable id => HsMatchContext id -> SDoc pprMatchContext ctxt - | want_an ctxt = ptext (sLit "an") <+> pprMatchContextNoun ctxt - | otherwise = ptext (sLit "a") <+> pprMatchContextNoun ctxt + | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt + | otherwise = text "a" <+> pprMatchContextNoun ctxt where want_an (FunRhs {}) = True -- Use "an" in front want_an ProcExpr = True want_an _ = False pprMatchContextNoun :: Outputable id => HsMatchContext id -> SDoc -pprMatchContextNoun (FunRhs fun) = ptext (sLit "equation for") +pprMatchContextNoun (FunRhs fun) = text "equation for" <+> quotes (ppr fun) -pprMatchContextNoun CaseAlt = ptext (sLit "case alternative") -pprMatchContextNoun IfAlt = ptext (sLit "multi-way if alternative") -pprMatchContextNoun RecUpd = ptext (sLit "record-update construct") -pprMatchContextNoun ThPatSplice = ptext (sLit "Template Haskell pattern splice") -pprMatchContextNoun ThPatQuote = ptext (sLit "Template Haskell pattern quotation") -pprMatchContextNoun PatBindRhs = ptext (sLit "pattern binding") -pprMatchContextNoun LambdaExpr = ptext (sLit "lambda abstraction") -pprMatchContextNoun ProcExpr = ptext (sLit "arrow abstraction") -pprMatchContextNoun (StmtCtxt ctxt) = ptext (sLit "pattern binding in") +pprMatchContextNoun CaseAlt = text "case alternative" +pprMatchContextNoun IfAlt = text "multi-way if alternative" +pprMatchContextNoun RecUpd = text "record-update construct" +pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice" +pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation" +pprMatchContextNoun PatBindRhs = text "pattern binding" +pprMatchContextNoun LambdaExpr = text "lambda abstraction" +pprMatchContextNoun ProcExpr = text "arrow abstraction" +pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" $$ pprStmtContext ctxt -pprMatchContextNoun PatSyn = ptext (sLit "pattern synonym declaration") +pprMatchContextNoun PatSyn = text "pattern synonym declaration" ----------------- pprAStmtContext, pprStmtContext :: Outputable id => HsStmtContext id -> SDoc pprAStmtContext ctxt = article <+> pprStmtContext ctxt where - pp_an = ptext (sLit "an") - pp_a = ptext (sLit "a") + pp_an = text "an" + pp_a = text "a" article = case ctxt of MDoExpr -> pp_an PArrComp -> pp_an @@ -2065,14 +2065,14 @@ pprAStmtContext ctxt = article <+> pprStmtContext ctxt ----------------- -pprStmtContext GhciStmtCtxt = ptext (sLit "interactive GHCi command") -pprStmtContext DoExpr = ptext (sLit "'do' block") -pprStmtContext MDoExpr = ptext (sLit "'mdo' block") -pprStmtContext ArrowExpr = ptext (sLit "'do' block in an arrow command") -pprStmtContext ListComp = ptext (sLit "list comprehension") -pprStmtContext MonadComp = ptext (sLit "monad comprehension") -pprStmtContext PArrComp = ptext (sLit "array comprehension") -pprStmtContext (PatGuard ctxt) = ptext (sLit "pattern guard for") $$ pprMatchContext ctxt +pprStmtContext GhciStmtCtxt = text "interactive GHCi command" +pprStmtContext DoExpr = text "'do' block" +pprStmtContext MDoExpr = text "'mdo' block" +pprStmtContext ArrowExpr = text "'do' block in an arrow command" +pprStmtContext ListComp = text "list comprehension" +pprStmtContext MonadComp = text "monad comprehension" +pprStmtContext PArrComp = text "array comprehension" +pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt -- Drop the inner contexts when reporting errors, else we get -- Unexpected transform statement @@ -2080,49 +2080,49 @@ pprStmtContext (PatGuard ctxt) = ptext (sLit "pattern guard for") $$ pprMatchCon -- transformed branch of -- transformed branch of monad comprehension pprStmtContext (ParStmtCtxt c) - | opt_PprStyle_Debug = sep [ptext (sLit "parallel branch of"), pprAStmtContext c] + | opt_PprStyle_Debug = sep [text "parallel branch of", pprAStmtContext c] | otherwise = pprStmtContext c pprStmtContext (TransStmtCtxt c) - | opt_PprStyle_Debug = sep [ptext (sLit "transformed branch of"), pprAStmtContext c] + | opt_PprStyle_Debug = sep [text "transformed branch of", pprAStmtContext c] | otherwise = pprStmtContext c -- Used to generate the string for a *runtime* error message matchContextErrString :: Outputable id => HsMatchContext id -> SDoc -matchContextErrString (FunRhs fun) = ptext (sLit "function") <+> ppr fun -matchContextErrString CaseAlt = ptext (sLit "case") -matchContextErrString IfAlt = ptext (sLit "multi-way if") -matchContextErrString PatBindRhs = ptext (sLit "pattern binding") -matchContextErrString RecUpd = ptext (sLit "record update") -matchContextErrString LambdaExpr = ptext (sLit "lambda") -matchContextErrString ProcExpr = ptext (sLit "proc") +matchContextErrString (FunRhs fun) = text "function" <+> ppr fun +matchContextErrString CaseAlt = text "case" +matchContextErrString IfAlt = text "multi-way if" +matchContextErrString PatBindRhs = text "pattern binding" +matchContextErrString RecUpd = text "record update" +matchContextErrString LambdaExpr = text "lambda" +matchContextErrString ProcExpr = text "proc" matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) -matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard") -matchContextErrString (StmtCtxt GhciStmtCtxt) = ptext (sLit "interactive GHCi command") -matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' block") -matchContextErrString (StmtCtxt ArrowExpr) = ptext (sLit "'do' block") -matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' block") -matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension") -matchContextErrString (StmtCtxt MonadComp) = ptext (sLit "monad comprehension") -matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension") +matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard" +matchContextErrString (StmtCtxt GhciStmtCtxt) = text "interactive GHCi command" +matchContextErrString (StmtCtxt DoExpr) = text "'do' block" +matchContextErrString (StmtCtxt ArrowExpr) = text "'do' block" +matchContextErrString (StmtCtxt MDoExpr) = text "'mdo' block" +matchContextErrString (StmtCtxt ListComp) = text "list comprehension" +matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension" +matchContextErrString (StmtCtxt PArrComp) = text "array comprehension" pprMatchInCtxt :: (OutputableBndr idL, OutputableBndr idR, Outputable body) => HsMatchContext idL -> Match idR body -> SDoc -pprMatchInCtxt ctxt match = hang (ptext (sLit "In") <+> pprMatchContext ctxt <> colon) +pprMatchInCtxt ctxt match = hang (text "In" <+> pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match) pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR, Outputable body) => HsStmtContext idL -> StmtLR idL idR body -> SDoc pprStmtInCtxt ctxt (LastStmt e _ _) | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts" - = hang (ptext (sLit "In the expression:")) 2 (ppr e) + = hang (text "In the expression:") 2 (ppr e) pprStmtInCtxt ctxt stmt - = hang (ptext (sLit "In a stmt of") <+> pprAStmtContext ctxt <> colon) + = hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon) 2 (ppr_stmt stmt) where -- For Group and Transform Stmts, don't print the nested stmts! diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs index b854b986be..493a92b910 100644 --- a/compiler/hsSyn/HsImpExp.hs +++ b/compiler/hsSyn/HsImpExp.hs @@ -90,7 +90,7 @@ instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name) , ideclSource = from, ideclSafe = safe , ideclQualified = qual, ideclImplicit = implicit , ideclAs = as, ideclHiding = spec }) - = hang (hsep [ptext (sLit "import"), ppr_imp from, pp_implicit implicit, pp_safe safe, + = hang (hsep [text "import", ppr_imp from, pp_implicit implicit, pp_safe safe, pp_qual qual, pp_pkg pkg, ppr mod', pp_as as]) 4 (pp_spec spec) where @@ -101,22 +101,22 @@ instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name) pp_pkg (Just (StringLiteral _ p)) = doubleQuotes (ftext p) pp_qual False = empty - pp_qual True = ptext (sLit "qualified") + pp_qual True = text "qualified" pp_safe False = empty - pp_safe True = ptext (sLit "safe") + pp_safe True = text "safe" pp_as Nothing = empty - pp_as (Just a) = ptext (sLit "as") <+> ppr a + pp_as (Just a) = text "as" <+> ppr a - ppr_imp True = ptext (sLit "{-# SOURCE #-}") + ppr_imp True = text "{-# SOURCE #-}" ppr_imp False = empty pp_spec Nothing = empty pp_spec (Just (False, (L _ ies))) = ppr_ies ies - pp_spec (Just (True, (L _ ies))) = ptext (sLit "hiding") <+> ppr_ies ies + pp_spec (Just (True, (L _ ies))) = text "hiding" <+> ppr_ies ies - ppr_ies [] = ptext (sLit "()") + ppr_ies [] = text "()" ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')' {- @@ -219,7 +219,7 @@ pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc pprImpExp name = type_pref <+> pprPrefixOcc name where occ = occName name - type_pref | isTcOcc occ && isSymOcc occ = ptext (sLit "type") + type_pref | isTcOcc occ && isSymOcc occ = text "type" | otherwise = empty instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where @@ -239,7 +239,7 @@ instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where let (bs, as) = splitAt pos (map (pprImpExp . unLoc) withs) in bs ++ [text ".."] ++ as ppr (IEModuleContents mod') - = ptext (sLit "module") <+> ppr mod' + = text "module" <+> ppr mod' ppr (IEGroup n _) = text ("<IEGroup: " ++ show n ++ ">") ppr (IEDoc doc) = ppr doc ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">") diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index ff1ce1ee79..9bb91d21f8 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -56,7 +56,6 @@ import TyCon import Outputable import Type import SrcLoc -import FastString import Bag -- collect ev vars from pats import Maybes -- libraries: @@ -431,7 +430,7 @@ instance (Outputable arg) ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n }) = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) where - dotdot = ptext (sLit "..") <+> ifPprDebug (ppr (drop n flds)) + dotdot = text ".." <+> ifPprDebug (ppr (drop n flds)) instance (Outputable id, Outputable arg) => Outputable (HsRecField' id arg) where diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs index 72525b2519..c226dfecf9 100644 --- a/compiler/hsSyn/HsSyn.hs +++ b/compiler/hsSyn/HsSyn.hs @@ -50,7 +50,6 @@ import OccName ( HasOccName ) import Outputable import SrcLoc import Module ( ModuleName ) -import FastString -- libraries: import Data.Data hiding ( Fixity ) @@ -120,11 +119,11 @@ instance (OutputableBndr name, HasOccName name) = vcat [ pp_mb mbDoc, case exports of - Nothing -> pp_header (ptext (sLit "where")) + Nothing -> pp_header (text "where") Just es -> vcat [ pp_header lparen, nest 8 (fsep (punctuate comma (map ppr (unLoc es)))), - nest 4 (ptext (sLit ") where")) + nest 4 (text ") where") ], pp_nonnull imports, pp_nonnull decls @@ -134,7 +133,7 @@ instance (OutputableBndr name, HasOccName name) Nothing -> pp_modname <+> rest Just d -> vcat [ pp_modname, ppr d, rest ] - pp_modname = ptext (sLit "module") <+> ppr name + pp_modname = text "module" <+> ppr name pp_mb :: Outputable t => Maybe t -> SDoc pp_mb (Just x) = ppr x diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 83161b309a..15de6a0941 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -1195,7 +1195,7 @@ ppr_fun_ty ctxt_prec ty1 ty2 p2 = ppr_mono_lty TopPrec ty2 in maybeParen ctxt_prec FunPrec $ - sep [p1, ptext (sLit "->") <+> p2] + sep [p1, text "->" <+> p2] -------------------------- ppr_app_ty :: OutputableBndr name => TyPrec -> HsAppType name -> SDoc diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 6f26e231de..7b6b34c728 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -527,7 +527,7 @@ pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs pprWithCommas pprIfaceIdBndr cvs) pp_lhs = hang pp_tc 2 (pprParendIfaceTcArgs pat_tys) maybe_incomps = ppUnless (null incomps) $ parens $ - ptext (sLit "incompatible indices:") <+> ppr incomps + text "incompatible indices:" <+> ppr incomps instance Outputable IfaceAnnotation where ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value @@ -609,7 +609,7 @@ ppr_trim xs where go (Just doc) (_, so_far) = (False, doc : so_far) go Nothing (True, so_far) = (True, so_far) - go Nothing (False, so_far) = (True, ptext (sLit "...") : so_far) + go Nothing (False, so_far) = (True, text "..." : so_far) isIfaceDataInstance :: IfaceTyConParent -> Bool isIfaceDataInstance IfNoParent = False @@ -637,12 +637,12 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, gadt_style = gadt || any (not . isVanillaIfaceConDecl) cons cons = visibleIfConDecls condecls - pp_where = ppWhen (gadt_style && not (null cons)) $ ptext (sLit "where") + pp_where = ppWhen (gadt_style && not (null cons)) $ text "where" pp_cons = ppr_trim (map show_con cons) :: [SDoc] pp_lhs = case parent of IfNoParent -> pprIfaceDeclHead context ss tycon kind tc_tyvars - _ -> ptext (sLit "instance") <+> pprIfaceTyConParent parent + _ -> text "instance" <+> pprIfaceTyConParent parent pp_roles | is_data_instance = empty @@ -682,9 +682,9 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, (tc_bndrs, _, _) = splitIfaceSigmaTy kind pp_nd = case condecls of - IfAbstractTyCon d -> ptext (sLit "abstract") <> ppShowIface ss (parens (ppr d)) - IfDataTyCon{} -> ptext (sLit "data") - IfNewTyCon{} -> ptext (sLit "newtype") + IfAbstractTyCon d -> text "abstract" <> ppShowIface ss (parens (ppr d)) + IfDataTyCon{} -> text "data" + IfNewTyCon{} -> text "newtype" pp_extra = vcat [pprCType ctype, pprRec isrec, text "Kind:" <+> ppr kind] @@ -695,14 +695,14 @@ pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec , ifFDs = fds, ifMinDef = minDef , ifKind = kind }) = vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) bndrs roles - , ptext (sLit "class") <+> pprIfaceDeclHead context ss clas kind tyvars + , text "class" <+> pprIfaceDeclHead context ss clas kind tyvars <+> pprFundeps fds <+> pp_where , nest 2 (vcat [ vcat asocs, vcat dsigs, pprec , ppShowAllSubs ss (pprMinDef minDef)])] where (bndrs, _, _) = splitIfaceSigmaTy kind - pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (ptext (sLit "where")) + pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where") asocs = ppr_trim $ map maybeShowAssoc ats dsigs = ppr_trim $ map maybeShowSig sigs @@ -720,16 +720,16 @@ pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec pprMinDef :: BooleanFormula IfLclName -> SDoc pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions - ptext (sLit "{-# MINIMAL") <+> + text "{-# MINIMAL" <+> pprBooleanFormula (\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+> - ptext (sLit "#-}") + text "#-}" pprIfaceDecl ss (IfaceSynonym { ifName = tc , ifTyVars = tv , ifSynRhs = mono_ty , ifSynKind = kind}) - = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] ss tc kind tv <+> equals) + = hang (text "type" <+> pprIfaceDeclHead [] ss tc kind tv <+> equals) 2 (sep [pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau]) where (tvs, theta, tau) = splitIfaceSigmaTy mono_ty @@ -738,7 +738,7 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars , ifFamFlav = rhs, ifFamKind = kind , ifResVar = res_var, ifFamInj = inj }) | IfaceDataFamilyTyCon <- rhs - = ptext (sLit "data family") <+> pprIfaceDeclHead [] ss tycon kind tyvars + = text "data family" <+> pprIfaceDeclHead [] ss tycon kind tyvars | otherwise = hang (text "type family" <+> pprIfaceDeclHead [] ss tycon kind tyvars) @@ -758,20 +758,20 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars tvs -> hsep [vbar, ppr res, text "->", interppSP (map fst tvs)] pp_rhs IfaceDataFamilyTyCon - = ppShowIface ss (ptext (sLit "data")) + = ppShowIface ss (text "data") pp_rhs IfaceOpenSynFamilyTyCon - = ppShowIface ss (ptext (sLit "open")) + = ppShowIface ss (text "open") pp_rhs IfaceAbstractClosedSynFamilyTyCon - = ppShowIface ss (ptext (sLit "closed, abstract")) + = ppShowIface ss (text "closed, abstract") pp_rhs (IfaceClosedSynFamilyTyCon {}) = empty -- see pp_branches pp_rhs IfaceBuiltInSynFamTyCon - = ppShowIface ss (ptext (sLit "built-in")) + = ppShowIface ss (text "built-in") pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs))) = hang (text "where") 2 (vcat (map (pprAxBranch (pprPrefixIfDeclBndr ss tycon)) brs) - $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax)) + $$ ppShowIface ss (text "axiom" <+> ppr ax)) pp_branches _ = Outputable.empty pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatBuilder = builder, @@ -798,13 +798,13 @@ pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty, pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon , ifAxBranches = branches }) - = hang (ptext (sLit "axiom") <+> ppr name <> dcolon) + = hang (text "axiom" <+> ppr name <> dcolon) 2 (vcat $ map (pprAxBranch (ppr tycon)) branches) pprCType :: Maybe CType -> SDoc pprCType Nothing = Outputable.empty -pprCType (Just cType) = ptext (sLit "C type:") <+> ppr cType +pprCType (Just cType) = text "C type:" <+> ppr cType -- if, for each role, suppress_if role is True, then suppress the role -- output @@ -814,11 +814,11 @@ pprRoles suppress_if tyCon bndrs roles = sdocWithDynFlags $ \dflags -> let froles = suppressIfaceInvisibles dflags bndrs roles in ppUnless (all suppress_if roles || null froles) $ - ptext (sLit "type role") <+> tyCon <+> hsep (map ppr froles) + text "type role" <+> tyCon <+> hsep (map ppr froles) pprRec :: RecFlag -> SDoc pprRec NonRecursive = Outputable.empty -pprRec Recursive = ptext (sLit "RecFlag: Recursive") +pprRec Recursive = text "RecFlag: Recursive" pprInfixIfDeclBndr, pprPrefixIfDeclBndr :: ShowSub -> OccName -> SDoc pprInfixIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) occ @@ -834,7 +834,7 @@ pprIfaceClassOp ss (IfaceClassOp n ty dm) = pp_sig n ty $$ generic_dm where generic_dm | Just (GenericDM dm_ty) <- dm - = ptext (sLit "default") <+> pp_sig n dm_ty + = text "default" <+> pp_sig n dm_ty | otherwise = empty pp_sig n ty = pprPrefixIfDeclBndr ss n <+> dcolon <+> pprIfaceSigmaType ty @@ -848,7 +848,7 @@ pprIfaceAT ss (IfaceAT d mb_def) , case mb_def of Nothing -> Outputable.empty Just rhs -> nest 2 $ - ptext (sLit "Default:") <+> ppr rhs ] + text "Default:" <+> ppr rhs ] instance Outputable IfaceTyConParent where ppr p = pprIfaceTyConParent p @@ -912,8 +912,8 @@ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls ppr_bang IfNoBang = ppWhen opt_PprStyle_Debug $ char '_' ppr_bang IfStrict = char '!' - ppr_bang IfUnpack = ptext (sLit "{-# UNPACK #-}") - ppr_bang (IfUnpackCo co) = ptext (sLit "! {-# UNPACK #-}") <> + ppr_bang IfUnpack = text "{-# UNPACK #-}" + ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <> pprParendIfaceCoercion co pprParendBangTy (bang, ty) = ppr_bang bang <> pprParendIfaceType ty @@ -939,22 +939,22 @@ instance Outputable IfaceRule where ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) = sep [hsep [pprRuleName name, ppr act, - ptext (sLit "forall") <+> pprIfaceBndrs bndrs], + text "forall" <+> pprIfaceBndrs bndrs], nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), - ptext (sLit "=") <+> ppr rhs]) + text "=" <+> ppr rhs]) ] instance Outputable IfaceClsInst where ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag , ifInstCls = cls, ifInstTys = mb_tcs}) - = hang (ptext (sLit "instance") <+> ppr flag + = hang (text "instance" <+> ppr flag <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) 2 (equals <+> ppr dfun_id) instance Outputable IfaceFamInst where ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs , ifFamInstAxiom = tycon_ax}) - = hang (ptext (sLit "family instance") <+> + = hang (text "family instance" <+> ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs) 2 (equals <+> ppr tycon_ax) @@ -1024,37 +1024,37 @@ pprIfaceExpr add_par i@(IfaceLam _ _) collect bs e = (reverse bs, e) pprIfaceExpr add_par (IfaceECase scrut ty) - = add_par (sep [ ptext (sLit "case") <+> pprIfaceExpr noParens scrut - , ptext (sLit "ret_ty") <+> pprParendIfaceType ty - , ptext (sLit "of {}") ]) + = add_par (sep [ text "case" <+> pprIfaceExpr noParens scrut + , text "ret_ty" <+> pprParendIfaceType ty + , text "of {}" ]) pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) - = add_par (sep [ptext (sLit "case") - <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") + = add_par (sep [text "case" + <+> pprIfaceExpr noParens scrut <+> text "of" <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, pprIfaceExpr noParens rhs <+> char '}']) pprIfaceExpr add_par (IfaceCase scrut bndr alts) - = add_par (sep [ptext (sLit "case") - <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") + = add_par (sep [text "case" + <+> pprIfaceExpr noParens scrut <+> text "of" <+> ppr bndr <+> char '{', nest 2 (sep (map ppr_alt alts)) <+> char '}']) pprIfaceExpr _ (IfaceCast expr co) = sep [pprParendIfaceExpr expr, - nest 2 (ptext (sLit "`cast`")), + nest 2 (text "`cast`"), pprParendIfaceCoercion co] pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body) - = add_par (sep [ptext (sLit "let {"), + = add_par (sep [text "let {", nest 2 (ppr_bind (b, rhs)), - ptext (sLit "} in"), + text "} in", pprIfaceExpr noParens body]) pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) - = add_par (sep [ptext (sLit "letrec {"), + = add_par (sep [text "letrec {", nest 2 (sep (map ppr_bind pairs)), - ptext (sLit "} in"), + text "} in", pprIfaceExpr noParens body]) pprIfaceExpr add_par (IfaceTick tickish e) @@ -1096,36 +1096,36 @@ instance Outputable IfaceConAlt where ------------------ instance Outputable IfaceIdDetails where ppr IfVanillaId = Outputable.empty - ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc + ppr (IfRecSelId tc b) = text "RecSel" <+> ppr tc <+> if b - then ptext (sLit "<naughty>") + then text "<naughty>" else Outputable.empty - ppr IfDFunId = ptext (sLit "DFunId") + ppr IfDFunId = text "DFunId" instance Outputable IfaceIdInfo where ppr NoInfo = Outputable.empty - ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is - <+> ptext (sLit "-}") + ppr (HasInfo is) = text "{-" <+> pprWithCommas ppr is + <+> text "-}" instance Outputable IfaceInfoItem where - ppr (HsUnfold lb unf) = ptext (sLit "Unfolding") - <> ppWhen lb (ptext (sLit "(loop-breaker)")) + ppr (HsUnfold lb unf) = text "Unfolding" + <> ppWhen lb (text "(loop-breaker)") <> colon <+> ppr unf - ppr (HsInline prag) = ptext (sLit "Inline:") <+> ppr prag - ppr (HsArity arity) = ptext (sLit "Arity:") <+> int arity - ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str - ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs") + ppr (HsInline prag) = text "Inline:" <+> ppr prag + ppr (HsArity arity) = text "Arity:" <+> int arity + ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str + ppr HsNoCafRefs = text "HasNoCafRefs" instance Outputable IfaceUnfolding where - ppr (IfCompulsory e) = ptext (sLit "<compulsory>") <+> parens (ppr e) + ppr (IfCompulsory e) = text "<compulsory>" <+> parens (ppr e) ppr (IfCoreUnfold s e) = (if s - then ptext (sLit "<stable>") + then text "<stable>" else Outputable.empty) <+> parens (ppr e) - ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") + ppr (IfInlineRule a uok bok e) = sep [text "InlineRule" <+> ppr (a,uok,bok), pprParendIfaceExpr e] - ppr (IfDFunUnfold bs es) = hang (ptext (sLit "DFun:") <+> sep (map ppr bs) <> dot) + ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot) 2 (sep (map pprParendIfaceExpr es)) {- diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index ac3f1b65db..09c7c6bb27 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -637,7 +637,7 @@ ppr_ty ctxt_prec (IfaceAppTy ty1 ty2) ppr_ty ctxt_prec (IfaceCastTy ty co) = maybeParen ctxt_prec FunPrec $ - sep [ppr_ty FunPrec ty, ptext (sLit "`cast`"), ppr_co FunPrec co] + sep [ppr_ty FunPrec ty, text "`cast`", ppr_co FunPrec co] ppr_ty ctxt_prec (IfaceCoercionTy co) = ppr_co ctxt_prec co @@ -778,7 +778,7 @@ pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> DynFlags -> SDoc pprTyTcApp ctxt_prec tc tys dflags | ifaceTyConName tc `hasKey` ipClassKey , ITC_Vis (IfaceLitTy (IfaceStrTyLit n)) (ITC_Vis ty ITC_Nil) <- tys - = char '?' <> ftext n <> ptext (sLit "::") <> ppr_ty TopPrec ty + = char '?' <> ftext n <> text "::" <> ppr_ty TopPrec ty | ifaceTyConName tc == consDataConName , not (gopt Opt_PrintExplicitKinds dflags) @@ -873,7 +873,7 @@ ppr_co _ (IfaceCoVarCo covar) = ppr covar ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2) = maybeParen ctxt_prec TyConPrec $ - ptext (sLit "UnsafeCo") <+> ppr r <+> + text "UnsafeCo" <+> ppr r <+> pprParendIfaceType ty1 <+> pprParendIfaceType ty2 ppr_co _ (IfaceUnivCo _ _ ty1 ty2) @@ -881,7 +881,7 @@ ppr_co _ (IfaceUnivCo _ _ ty1 ty2) ppr_co ctxt_prec (IfaceInstCo co ty) = maybeParen ctxt_prec TyConPrec $ - ptext (sLit "Inst") <+> pprParendIfaceCoercion co + text "Inst" <+> pprParendIfaceCoercion co <+> pprParendIfaceCoercion ty ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos) @@ -891,12 +891,12 @@ ppr_co ctxt_prec co = ppr_special_co ctxt_prec doc cos where (doc, cos) = case co of { IfaceAxiomInstCo n i cos -> (ppr n <> brackets (ppr i), cos) - ; IfaceSymCo co -> (ptext (sLit "Sym"), [co]) - ; IfaceTransCo co1 co2 -> (ptext (sLit "Trans"), [co1,co2]) - ; IfaceNthCo d co -> (ptext (sLit "Nth:") <> int d, + ; IfaceSymCo co -> (text "Sym", [co]) + ; IfaceTransCo co1 co2 -> (text "Trans", [co1,co2]) + ; IfaceNthCo d co -> (text "Nth:" <> int d, [co]) ; IfaceLRCo lr co -> (ppr lr, [co]) - ; IfaceSubCo co -> (ptext (sLit "Sub"), [co]) + ; IfaceSubCo co -> (text "Sub", [co]) ; _ -> panic "pprIfaceCo" } ppr_special_co :: TyPrec -> SDoc -> [IfaceCoercion] -> SDoc diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index 35c6b22027..c044136b36 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -141,11 +141,11 @@ importDecl name Nothing -> return (Failed not_found_msg) }}} where - nd_doc = ptext (sLit "Need decl for") <+> ppr name - not_found_msg = hang (ptext (sLit "Can't find interface-file declaration for") <+> + nd_doc = text "Need decl for" <+> ppr name + not_found_msg = hang (text "Can't find interface-file declaration for" <+> pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name) - 2 (vcat [ptext (sLit "Probable cause: bug in .hi-boot file, or inconsistent .hi file"), - ptext (sLit "Use -ddump-if-trace to get an idea of which file caused the error")]) + 2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file", + text "Use -ddump-if-trace to get an idea of which file caused the error"]) {- @@ -325,7 +325,7 @@ loadWiredInHomeIface name = ASSERT( isWiredInName name ) do _ <- loadSysInterface doc (nameModule name); return () where - doc = ptext (sLit "Need home interface for wired-in thing") <+> ppr name + doc = text "Need home interface for wired-in thing" <+> ppr name ------------------ -- | Loads a system interface and throws an exception if it fails @@ -520,8 +520,8 @@ wantHiBootFile dflags eps mod from badSourceImport :: Module -> SDoc badSourceImport mod - = hang (ptext (sLit "You cannot {-# SOURCE #-} import a module from another package")) - 2 (ptext (sLit "but") <+> quotes (ppr mod) <+> ptext (sLit "is from package") + = hang (text "You cannot {-# SOURCE #-} import a module from another package") + 2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package") <+> quotes (ppr (moduleUnitId mod))) ----------------------------------------------------- @@ -637,7 +637,7 @@ loadDecl ignore_prags (_version, decl) [(n, lookup n) | n <- implicit_names] } where - doc = ptext (sLit "Declaration for") <+> ppr (ifName decl) + doc = text "Declaration for" <+> ppr (ifName decl) bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used bumpDeclStats name @@ -684,13 +684,13 @@ findAndReadIface :: SDoc -> Module -- sometimes it's ok to fail... see notes with loadInterface findAndReadIface doc_str mod hi_boot_file - = do traceIf (sep [hsep [ptext (sLit "Reading"), + = do traceIf (sep [hsep [text "Reading", if hi_boot_file - then ptext (sLit "[boot]") + then text "[boot]" else Outputable.empty, - ptext (sLit "interface for"), + text "interface for", ppr mod <> semi], - nest 4 (ptext (sLit "reason:") <+> doc_str)]) + nest 4 (text "reason:" <+> doc_str)]) -- Check for GHC.Prim, and return its static interface if mod == gHC_PRIM @@ -718,12 +718,12 @@ findAndReadIface doc_str mod hi_boot_file checkBuildDynamicToo r return r err -> do - traceIf (ptext (sLit "...not found")) + traceIf (text "...not found") dflags <- getDynFlags return (Failed (cannotFindInterface dflags (moduleName mod) err)) where read_file file_path = do - traceIf (ptext (sLit "readIFace") <+> text file_path) + traceIf (text "readIFace" <+> text file_path) read_result <- readIface mod file_path case read_result of Failed err -> return (Failed (badIfaceFile file_path err)) @@ -866,11 +866,11 @@ showIface hsc_env filename = do pprModIface :: ModIface -> SDoc -- Show a ModIface pprModIface iface - = vcat [ ptext (sLit "interface") + = vcat [ text "interface" <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface) - <+> (if mi_orphan iface then ptext (sLit "[orphan module]") else Outputable.empty) - <+> (if mi_finsts iface then ptext (sLit "[family instance module]") else Outputable.empty) - <+> (if mi_hpc iface then ptext (sLit "[hpc]") else Outputable.empty) + <+> (if mi_orphan iface then text "[orphan module]" else Outputable.empty) + <+> (if mi_finsts iface then text "[family instance module]" else Outputable.empty) + <+> (if mi_hpc iface then text "[hpc]" else Outputable.empty) <+> integer hiVersion , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface)) , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface)) @@ -879,8 +879,8 @@ pprModIface iface , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash iface)) , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface)) , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface)) - , nest 2 (ptext (sLit "where")) - , ptext (sLit "exports:") + , nest 2 (text "where") + , text "exports:" , nest 2 (vcat (map pprExport (mi_exports iface))) , pprDeps (mi_deps iface) , vcat (map pprUsage (mi_usages iface)) @@ -896,8 +896,8 @@ pprModIface iface , pprTrustPkg (mi_trust_pkg iface) ] where - pp_hsc_src HsBootFile = ptext (sLit "[boot]") - pp_hsc_src HsigFile = ptext (sLit "[hsig]") + pp_hsc_src HsBootFile = text "[boot]" + pp_hsc_src HsigFile = text "[hsig]" pp_hsc_src HsSrcFile = Outputable.empty {- @@ -928,24 +928,24 @@ pprUsage usage@UsageHomeModule{} vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ] ) pprUsage usage@UsageFile{} - = hsep [ptext (sLit "addDependentFile"), + = hsep [text "addDependentFile", doubleQuotes (text (usg_file_path usage))] pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc pprUsageImport usage usg_mod' - = hsep [ptext (sLit "import"), safe, ppr (usg_mod' usage), + = hsep [text "import", safe, ppr (usg_mod' usage), ppr (usg_mod_hash usage)] where - safe | usg_safe usage = ptext $ sLit "safe" - | otherwise = ptext $ sLit " -/ " + safe | usg_safe usage = text "safe" + | otherwise = text " -/ " pprDeps :: Dependencies -> SDoc pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, dep_finsts = finsts }) - = vcat [ptext (sLit "module dependencies:") <+> fsep (map ppr_mod mods), - ptext (sLit "package dependencies:") <+> fsep (map ppr_pkg pkgs), - ptext (sLit "orphans:") <+> fsep (map ppr orphs), - ptext (sLit "family instance modules:") <+> fsep (map ppr finsts) + = vcat [text "module dependencies:" <+> fsep (map ppr_mod mods), + text "package dependencies:" <+> fsep (map ppr_pkg pkgs), + text "orphans:" <+> fsep (map ppr orphs), + text "family instance modules:" <+> fsep (map ppr finsts) ] where ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot @@ -956,7 +956,7 @@ pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, pprFixities :: [(OccName, Fixity)] -> SDoc pprFixities [] = Outputable.empty -pprFixities fixes = ptext (sLit "fixities") <+> pprWithCommas pprFix fixes +pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes where pprFix (occ,fix) = ppr fix <+> ppr occ @@ -968,32 +968,32 @@ pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars , ifaceVectInfoParallelTyCons = parallelTyCons }) = vcat - [ ptext (sLit "vectorised variables:") <+> hsep (map ppr vars) - , ptext (sLit "vectorised tycons:") <+> hsep (map ppr tycons) - , ptext (sLit "vectorised reused tycons:") <+> hsep (map ppr tyconsReuse) - , ptext (sLit "parallel variables:") <+> hsep (map ppr parallelVars) - , ptext (sLit "parallel tycons:") <+> hsep (map ppr parallelTyCons) + [ text "vectorised variables:" <+> hsep (map ppr vars) + , text "vectorised tycons:" <+> hsep (map ppr tycons) + , text "vectorised reused tycons:" <+> hsep (map ppr tyconsReuse) + , text "parallel variables:" <+> hsep (map ppr parallelVars) + , text "parallel tycons:" <+> hsep (map ppr parallelTyCons) ] pprTrustInfo :: IfaceTrustInfo -> SDoc -pprTrustInfo trust = ptext (sLit "trusted:") <+> ppr trust +pprTrustInfo trust = text "trusted:" <+> ppr trust pprTrustPkg :: Bool -> SDoc -pprTrustPkg tpkg = ptext (sLit "require own pkg trusted:") <+> ppr tpkg +pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg instance Outputable Warnings where ppr = pprWarns pprWarns :: Warnings -> SDoc pprWarns NoWarnings = Outputable.empty -pprWarns (WarnAll txt) = ptext (sLit "Warn all") <+> ppr txt -pprWarns (WarnSome prs) = ptext (sLit "Warnings") +pprWarns (WarnAll txt) = text "Warn all" <+> ppr txt +pprWarns (WarnSome prs) = text "Warnings" <+> vcat (map pprWarning prs) where pprWarning (name, txt) = ppr name <+> ppr txt pprIfaceAnnotation :: IfaceAnnotation -> SDoc pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized }) - = ppr target <+> ptext (sLit "annotated by") <+> ppr serialized + = ppr target <+> text "annotated by" <+> ppr serialized {- ********************************************************* @@ -1005,7 +1005,7 @@ pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedVal badIfaceFile :: String -> SDoc -> SDoc badIfaceFile file err - = vcat [ptext (sLit "Bad interface file:") <+> text file, + = vcat [text "Bad interface file:" <+> text file, nest 4 err] hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc @@ -1015,20 +1015,20 @@ hiModuleNameMismatchWarn requested_mod read_mod = withPprStyle (mkUserStyle alwaysQualify AllTheWay) $ -- we want the Modules below to be qualified with package names, -- so reset the PrintUnqualified setting. - hsep [ ptext (sLit "Something is amiss; requested module ") + hsep [ text "Something is amiss; requested module " , ppr requested_mod - , ptext (sLit "differs from name found in the interface file") + , text "differs from name found in the interface file" , ppr read_mod ] wrongIfaceModErr :: ModIface -> Module -> String -> SDoc wrongIfaceModErr iface mod_name file_path - = sep [ptext (sLit "Interface file") <+> iface_file, - ptext (sLit "contains module") <+> quotes (ppr (mi_module iface)) <> comma, - ptext (sLit "but we were expecting module") <+> quotes (ppr mod_name), - sep [ptext (sLit "Probable cause: the source code which generated"), + = sep [text "Interface file" <+> iface_file, + text "contains module" <+> quotes (ppr (mi_module iface)) <> comma, + text "but we were expecting module" <+> quotes (ppr mod_name), + sep [text "Probable cause: the source code which generated", nest 2 iface_file, - ptext (sLit "has an incompatible module name") + text "has an incompatible module name" ] ] where iface_file = doubleQuotes (text file_path) @@ -1036,8 +1036,8 @@ wrongIfaceModErr iface mod_name file_path homeModError :: Module -> ModLocation -> SDoc -- See Note [Home module load error] homeModError mod location - = ptext (sLit "attempting to use module ") <> quotes (ppr mod) + = text "attempting to use module " <> quotes (ppr mod) <> (case ml_hs_file location of Just file -> space <> parens (text file) Nothing -> Outputable.empty) - <+> ptext (sLit "which is not loaded") + <+> text "which is not loaded" diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 9e4c30355c..1db02bd314 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -735,7 +735,7 @@ instance Outputable IfaceDeclExtras where ppr_id_extras_s stuff] ppr_insts :: [IfaceInstABI] -> SDoc -ppr_insts _ = ptext (sLit "<insts>") +ppr_insts _ = text "<insts>" ppr_id_extras_s :: [IfaceIdExtras] -> SDoc ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff) @@ -1068,9 +1068,9 @@ checkFlagHash hsc_env iface = do (mi_module iface) putNameLiterally case old_hash == new_hash of - True -> up_to_date (ptext $ sLit "Module flags unchanged") + True -> up_to_date (text "Module flags unchanged") False -> out_of_date_hash "flags changed" - (ptext $ sLit " Module flags have changed") + (text " Module flags have changed") old_hash new_hash -- If the direct imports of this module are resolved to targets that @@ -1121,7 +1121,7 @@ needInterface :: Module -> (ModIface -> IfG RecompileRequired) -> IfG RecompileRequired needInterface mod continue = do -- Load the imported interface if possible - let doc_str = sep [ptext (sLit "need version info for"), ppr mod] + let doc_str = sep [text "need version info for", ppr mod] traceHiDiffs (text "Checking usages for module" <+> ppr mod) mb_iface <- loadInterface doc_str mod ImportBySystem @@ -1130,7 +1130,7 @@ needInterface mod continue case mb_iface of Failed _ -> do - traceHiDiffs (sep [ptext (sLit "Couldn't load interface for module"), + traceHiDiffs (sep [text "Couldn't load interface for module", ppr mod]) return MustCompile -- Couldn't find or parse a module mentioned in the @@ -1179,14 +1179,14 @@ checkModUsage this_pkg UsageHomeModule{ -- CHECK EXPORT LIST checkMaybeHash reason maybe_old_export_hash new_export_hash - (ptext (sLit " Export list changed")) $ do + (text " Export list changed") $ do -- CHECK ITEMS ONE BY ONE recompile <- checkList [ checkEntityUsage reason new_decl_hash u | u <- old_decl_hash] if recompileRequired recompile then return recompile -- This one failed, so just bail out now - else up_to_date (ptext (sLit " Great! The bits I use are up to date")) + else up_to_date (text " Great! The bits I use are up to date") checkModUsage _this_pkg UsageFile{ usg_file_path = file, @@ -1211,10 +1211,10 @@ checkModuleFingerprint :: String -> Fingerprint -> Fingerprint -> IfG RecompileRequired checkModuleFingerprint reason old_mod_hash new_mod_hash | new_mod_hash == old_mod_hash - = up_to_date (ptext (sLit "Module fingerprint unchanged")) + = up_to_date (text "Module fingerprint unchanged") | otherwise - = out_of_date_hash reason (ptext (sLit " Module fingerprint has changed")) + = out_of_date_hash reason (text " Module fingerprint has changed") old_mod_hash new_mod_hash ------------------------ @@ -1235,12 +1235,12 @@ checkEntityUsage reason new_hash (name,old_hash) = case new_hash name of Nothing -> -- We used it before, but it ain't there now - out_of_date reason (sep [ptext (sLit "No longer exported:"), ppr name]) + out_of_date reason (sep [text "No longer exported:", ppr name]) Just (_, new_hash) -- It's there, but is it up to date? | new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash)) return UpToDate - | otherwise -> out_of_date_hash reason (ptext (sLit " Out of date:") <+> ppr name) + | otherwise -> out_of_date_hash reason (text " Out of date:" <+> ppr name) old_hash new_hash up_to_date :: SDoc -> IfG RecompileRequired @@ -1251,7 +1251,7 @@ out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason) out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired out_of_date_hash reason msg old_hash new_hash - = out_of_date reason (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash]) + = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash]) ---------------------- checkList :: [IfG RecompileRequired] -> IfG RecompileRequired diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index b579b656e6..9d1886d27c 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -224,13 +224,13 @@ tcHiBootIface hsc_src mod -- The hi-boot file has mysteriously disappeared. }}}} where - need = ptext (sLit "Need the hi-boot interface for") <+> ppr mod - <+> ptext (sLit "to compare against the Real Thing") + need = text "Need the hi-boot interface for" <+> ppr mod + <+> text "to compare against the Real Thing" - moduleLoop = ptext (sLit "Circular imports: module") <+> quotes (ppr mod) - <+> ptext (sLit "depends on itself") + moduleLoop = text "Circular imports: module" <+> quotes (ppr mod) + <+> text "depends on itself" - elaborate err = hang (ptext (sLit "Could not find hi-boot interface for") <+> + elaborate err = hang (text "Could not find hi-boot interface for" <+> quotes (ppr mod) <> colon) 4 err @@ -353,7 +353,7 @@ tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, ifTyVars = tv_bndrs, ; let tycon = mkSynonymTyCon tc_name kind tyvars roles rhs ; return (ATyCon tycon) } where - mk_doc n = ptext (sLit "Type synonym") <+> ppr n + mk_doc n = text "Type synonym" <+> ppr n tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs, ifFamFlav = fam_flav, @@ -368,7 +368,7 @@ tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs, ; let tycon = mkFamilyTyCon tc_name kind tyvars res_name rhs parent inj ; return (ATyCon tycon) } where - mk_doc n = ptext (sLit "Type synonym") <+> ppr n + mk_doc n = text "Type synonym" <+> ppr n tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav tc_fam_flav tc_name IfaceDataFamilyTyCon @@ -448,9 +448,9 @@ tc_iface_decl _parent ignore_prags -- e.g. type AT a; type AT b = AT [b] Trac #8002 return (ATI tc mb_def) - mk_sc_doc pred = ptext (sLit "Superclass") <+> ppr pred - mk_at_doc tc = ptext (sLit "Associated type") <+> ppr tc - mk_op_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty] + mk_sc_doc pred = text "Superclass" <+> ppr pred + mk_at_doc tc = text "Associated type" <+> ppr tc + mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty] tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1 ; tvs2' <- mapM tcIfaceTyVar tvs2 @@ -481,7 +481,7 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name , ifPatTy = pat_ty , ifFieldLabels = field_labels }) = do { name <- lookupIfaceTop occ_name - ; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name) + ; traceIf (text "tc_iface_decl" <+> ppr name) ; matcher <- tc_pr if_matcher ; builder <- fmapMaybeM tc_pr if_builder ; bindIfaceTvBndrs univ_tvs $ \univ_tvs -> do @@ -496,7 +496,7 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name arg_tys pat_ty field_labels } ; return $ AConLike . PatSynCon $ patsyn }}} where - mk_doc n = ptext (sLit "Pattern synonym") <+> ppr n + mk_doc n = text "Pattern synonym" <+> ppr n tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool) tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm) ; return (id, b) } @@ -589,7 +589,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons arg_tys orig_res_ty tycon ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name) ; return con } - mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name + mk_doc con_name = text "Constructor" <+> ppr con_name tc_strict :: IfaceBang -> IfL HsImplBang tc_strict IfNoBang = return (HsLazy) @@ -639,7 +639,7 @@ tcIfaceInst :: IfaceClsInst -> IfL ClsInst tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag , ifInstCls = cls, ifInstTys = mb_tcs , ifInstOrph = orph }) - = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $ + = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_occ) $ tcIfaceExtId dfun_occ ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs ; return (mkImportedInstance cls mb_tcs' dfun oflag orph) } @@ -647,7 +647,7 @@ tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs , ifFamInstAxiom = axiom_name } ) - = do { axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $ + = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $ tcIfaceCoAxiom axiom_name -- will panic if branched, but that's OK ; let axiom'' = toUnbranchedAxiom axiom' @@ -679,7 +679,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd ifRuleAuto = auto, ifRuleOrph = orph }) = do { ~(bndrs', args', rhs') <- -- Typecheck the payload lazily, in the hope it'll never be looked at - forkM (ptext (sLit "Rule") <+> pprRuleName name) $ + forkM (text "Rule" <+> pprRuleName name) $ bindIfaceBndrs bndrs $ \ bndrs' -> do { args' <- mapM tcIfaceExpr args ; rhs' <- tcIfaceExpr rhs @@ -778,11 +778,11 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo where vectVarMapping name = do { vName <- lookupIfaceTop (mkLocalisedOccName mod mkVectOcc name) - ; var <- forkM (ptext (sLit "vect var") <+> ppr name) $ + ; var <- forkM (text "vect var" <+> ppr name) $ tcIfaceExtId name - ; vVar <- forkM (ptext (sLit "vect vVar [mod =") <+> - ppr mod <> ptext (sLit "; nameModule =") <+> - ppr (nameModule name) <> ptext (sLit "]") <+> ppr vName) $ + ; vVar <- forkM (text "vect vVar [mod =" <+> + ppr mod <> text "; nameModule =" <+> + ppr (nameModule name) <> text "]" <+> ppr vName) $ tcIfaceExtId vName ; return (var, (var, vVar)) } @@ -801,7 +801,7 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo -- notAnIdErr = pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name) vectVar name - = forkM (ptext (sLit "vect scalar var") <+> ppr name) $ + = forkM (text "vect scalar var" <+> ppr name) $ tcIfaceExtId name vectTyConVectMapping vars name @@ -814,7 +814,7 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo vectTyConMapping vars name vName = do { tycon <- lookupLocalOrExternalTyCon name - ; vTycon <- forkM (ptext (sLit "vTycon of") <+> ppr vName) $ + ; vTycon <- forkM (text "vTycon of" <+> ppr vName) $ lookupLocalOrExternalTyCon vName -- Map the data constructors of the original type constructor to those of the @@ -1261,10 +1261,10 @@ tcPragExpr name expr Nothing -> return () Just fail_msg -> do { mod <- getIfModule ; pprPanic "Iface Lint failure" - (vcat [ ptext (sLit "In interface for") <+> ppr mod + (vcat [ text "In interface for" <+> ppr mod , hang doc 2 fail_msg , ppr name <+> equals <+> ppr core_expr' - , ptext (sLit "Iface expr =") <+> ppr expr ]) } + , text "Iface expr =" <+> ppr expr ]) } return core_expr' where doc = text "Unfolding of" <+> ppr name diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index 611d3964c5..46fe4e0aad 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -343,16 +343,16 @@ dumpModCycles dflags mod_summaries = return () | null cycles - = putMsg dflags (ptext (sLit "No module cycles")) + = putMsg dflags (text "No module cycles") | otherwise - = putMsg dflags (hang (ptext (sLit "Module cycles found:")) 2 pp_cycles) + = putMsg dflags (hang (text "Module cycles found:") 2 pp_cycles) where cycles :: [[ModSummary]] cycles = [ c | CyclicSCC c <- GHC.topSortModuleGraph True mod_summaries Nothing ] - pp_cycles = vcat [ (ptext (sLit "---------- Cycle") <+> int n <+> ptext (sLit "----------")) + pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------")) $$ pprCycle c $$ blankLine | (n,c) <- [1..] `zip` cycles ] @@ -382,7 +382,7 @@ pprCycle summaries = pp_group (CyclicSCC summaries) pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' ')) <+> (pp_imps empty (map snd (ms_imps summary)) $$ - pp_imps (ptext (sLit "{-# SOURCE #-}")) (map snd (ms_srcimps summary))) + pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary))) where mod_str = moduleNameString (moduleName (ms_mod summary)) @@ -391,7 +391,7 @@ pprCycle summaries = pp_group (CyclicSCC summaries) pp_imps what lms = case [m | L _ m <- lms, m `elem` cycle_mods] of [] -> empty - ms -> what <+> ptext (sLit "imports") <+> + ms -> what <+> text "imports" <+> pprWithCommas ppr ms ----------------------------------------------------------------- diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 047e12e146..f40efd0f84 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -56,7 +56,6 @@ import StringBuffer ( hGetStringBuffer ) import BasicTypes ( SuccessFlag(..) ) import Maybes ( expectJust ) import SrcLoc -import FastString import LlvmCodeGen ( llvmFixupAsm ) import MonadUtils import Platform @@ -372,7 +371,7 @@ link' dflags batch_attempt_linking hpt linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps if not (gopt Opt_ForceRecomp dflags) && not linking_needed - then do debugTraceMsg dflags 2 (text exe_file <+> ptext (sLit "is up to date, linking not required.")) + then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.") return Succeeded else do @@ -684,7 +683,7 @@ pipeLoop phase input_fn = do _ -> do liftIO $ debugTraceMsg dflags 4 - (ptext (sLit "Running phase") <+> ppr phase) + (text "Running phase" <+> ppr phase) (next_phase, output_fn) <- runHookedPhase phase input_fn dflags r <- pipeLoop next_phase output_fn case phase of @@ -1618,7 +1617,7 @@ mkExtraObjToLinkIntoBinary dflags = do else "rtsFalse") <> semi, case rtsOpts dflags of Nothing -> Outputable.empty - Just opts -> ptext (sLit " __conf.rts_opts= ") <> + Just opts -> text " __conf.rts_opts= " <> text (show opts) <> semi, text " __conf.rts_hs_main = rtsTrue;", text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);", diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index acaa722d90..d28dd30773 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1106,9 +1106,9 @@ data GhcMode deriving Eq instance Outputable GhcMode where - ppr CompManager = ptext (sLit "CompManager") - ppr OneShot = ptext (sLit "OneShot") - ppr MkDepend = ptext (sLit "MkDepend") + ppr CompManager = text "CompManager" + ppr OneShot = text "OneShot" + ppr MkDepend = text "MkDepend" isOneShot :: GhcMode -> Bool isOneShot OneShot = True diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs index ba351457df..e7a2b953ed 100644 --- a/compiler/main/DynamicLoading.hs +++ b/compiler/main/DynamicLoading.hs @@ -84,8 +84,8 @@ loadPlugin' occ_name plugin_name hsc_env mod_name ; case mb_name of { Nothing -> throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep - [ ptext (sLit "The module"), ppr mod_name - , ptext (sLit "did not export the plugin name") + [ text "The module", ppr mod_name + , text "did not export the plugin name" , ppr plugin_rdr_name ]) ; Just name -> @@ -94,9 +94,9 @@ loadPlugin' occ_name plugin_name hsc_env mod_name ; case mb_plugin of Nothing -> throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep - [ ptext (sLit "The value"), ppr name - , ptext (sLit "did not have the type") - , ppr pluginTyConName, ptext (sLit "as required")]) + [ text "The value", ppr name + , text "did not have the type" + , ppr pluginTyConName, text "as required"]) Just plugin -> return plugin } } } @@ -123,7 +123,7 @@ forceLoadNameModuleInterface hsc_env reason name = do -- * The name did not exist in the loaded module forceLoadTyCon :: HscEnv -> Name -> IO TyCon forceLoadTyCon hsc_env con_name = do - forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of loadTyConTy")) con_name + forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of loadTyConTy") con_name mb_con_thing <- lookupTypeHscEnv hsc_env con_name case mb_con_thing of @@ -155,7 +155,7 @@ getValueSafely hsc_env val_name expected_type = do getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue) getHValueSafely hsc_env val_name expected_type = do - forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of getHValueSafely")) val_name + forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name -- Now look up the names for the value and type constructor in the type environment mb_val_thing <- lookupTypeHscEnv hsc_env val_name case mb_val_thing of @@ -185,9 +185,10 @@ getHValueSafely hsc_env val_name expected_type = do -- if it /does/ segfault lessUnsafeCoerce :: DynFlags -> String -> a -> IO b lessUnsafeCoerce dflags context what = do - debugTraceMsg dflags 3 $ (ptext $ sLit "Coercing a value in") <+> (text context) <> (ptext $ sLit "...") + debugTraceMsg dflags 3 $ (text "Coercing a value in") <+> (text context) <> + (text "...") output <- evaluate (unsafeCoerce# what) - debugTraceMsg dflags 3 $ ptext $ sLit "Successfully evaluated coercion" + debugTraceMsg dflags 3 (text "Successfully evaluated coercion") return output @@ -225,17 +226,17 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do [] -> return Nothing _ -> panic "lookupRdrNameInModule" - Nothing -> throwCmdLineErrorS dflags $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name] + Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name] err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err where dflags = hsc_dflags hsc_env - doc = ptext (sLit "contains a name used in an invocation of lookupRdrNameInModule") + doc = text "contains a name used in an invocation of lookupRdrNameInModule" wrongTyThingError :: Name -> TyThing -> SDoc -wrongTyThingError name got_thing = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing] +wrongTyThingError name got_thing = hsep [text "The name", ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing] missingTyThingError :: Name -> SDoc -missingTyThingError name = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")] +missingTyThingError name = hsep [text "The name", ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")] throwCmdLineErrorS :: DynFlags -> SDoc -> IO a throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs index 11b30fd13c..eafe4e802f 100644 --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -53,7 +53,6 @@ import Bag import Exception import Outputable import Panic -import FastString import SrcLoc import DynFlags @@ -174,9 +173,9 @@ mkLocMessage severity locn msg -- Add prefixes, like Foo.hs:34: warning: -- <the warning message> sev_info = case severity of - SevWarning -> ptext (sLit "warning:") - SevError -> ptext (sLit "error:") - SevFatal -> ptext (sLit "fatal:") + SevWarning -> text "warning:" + SevError -> text "error:" + SevFatal -> text "fatal:" _ -> empty makeIntoWarning :: ErrMsg -> ErrMsg diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs index 2ac0737251..e11480c497 100644 --- a/compiler/main/Finder.hs +++ b/compiler/main/Finder.hs @@ -544,7 +544,7 @@ cantFindErr :: LitString -> LitString -> DynFlags -> ModuleName -> FindResult cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) | Just pkgs <- unambiguousPackages = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( - sep [ptext (sLit "it was found in multiple packages:"), + sep [text "it was found in multiple packages:", hsep (map ppr pkgs) ] ) | otherwise @@ -557,16 +557,16 @@ cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) = Just (moduleUnitId m : xs) unambiguousPackage _ _ = Nothing - pprMod (m, o) = ptext (sLit "it is bound as") <+> ppr m <+> - ptext (sLit "by") <+> pprOrigin m o + pprMod (m, o) = text "it is bound as" <+> ppr m <+> + text "by" <+> pprOrigin m o pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( if e == Just True - then [ptext (sLit "package") <+> ppr (moduleUnitId m)] + then [text "package" <+> ppr (moduleUnitId m)] else [] ++ - map ((ptext (sLit "a reexport in package") <+>) + map ((text "a reexport in package" <+>) .ppr.packageConfigId) res ++ - if f then [ptext (sLit "a package flag")] else [] + if f then [text "a package flag"] else [] ) cantFindErr cannot_find _ dflags mod_name find_result @@ -576,8 +576,8 @@ cantFindErr cannot_find _ dflags mod_name find_result more_info = case find_result of NoPackage pkg - -> ptext (sLit "no unit id matching") <+> quotes (ppr pkg) <+> - ptext (sLit "was found") $$ looks_like_srcpkgid pkg + -> text "no unit id matching" <+> quotes (ppr pkg) <+> + text "was found" $$ looks_like_srcpkgid pkg NotFound { fr_paths = files, fr_pkg = mb_pkg , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens @@ -589,7 +589,7 @@ cantFindErr cannot_find _ dflags mod_name find_result -> pp_suggestions suggest $$ tried_these files | null files && null mod_hiddens && null pkg_hiddens - -> ptext (sLit "It is not a module in the current program, or in any known package.") + -> text "It is not a module in the current program, or in any known package." | otherwise -> vcat (map pkg_hidden pkg_hiddens) $$ @@ -606,26 +606,26 @@ cantFindErr cannot_find _ dflags mod_name find_result build = if build_tag == "p" then "profiling" else "\"" ++ build_tag ++ "\"" in - ptext (sLit "Perhaps you haven't installed the ") <> text build <> - ptext (sLit " libraries for package ") <> quotes (ppr pkg) <> char '?' $$ + text "Perhaps you haven't installed the " <> text build <> + text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ tried_these files | otherwise - = ptext (sLit "There are files missing in the ") <> quotes (ppr pkg) <> - ptext (sLit " package,") $$ - ptext (sLit "try running 'ghc-pkg check'.") $$ + = text "There are files missing in the " <> quotes (ppr pkg) <> + text " package," $$ + text "try running 'ghc-pkg check'." $$ tried_these files tried_these files | null files = Outputable.empty | verbosity dflags < 3 = - ptext (sLit "Use -v to see a list of the files searched for.") + text "Use -v to see a list of the files searched for." | otherwise = - hang (ptext (sLit "Locations searched:")) 2 $ vcat (map text files) + hang (text "Locations searched:") 2 $ vcat (map text files) pkg_hidden :: UnitId -> SDoc pkg_hidden pkgid = - ptext (sLit "It is a member of the hidden package") + text "It is a member of the hidden package" <+> quotes (ppr pkgid) --FIXME: we don't really want to show the unit id here we should -- show the source package id or installed package id if it's ambiguous @@ -633,9 +633,9 @@ cantFindErr cannot_find _ dflags mod_name find_result cabal_pkg_hidden_hint pkgid | gopt Opt_BuildingCabalPackage dflags = let pkg = expectJust "pkg_hidden" (lookupPackage dflags pkgid) - in ptext (sLit "Perhaps you need to add") <+> + in text "Perhaps you need to add" <+> quotes (ppr (packageName pkg)) <+> - ptext (sLit "to the build-depends in your .cabal file.") + text "to the build-depends in your .cabal file." | otherwise = Outputable.empty looks_like_srcpkgid :: UnitId -> SDoc @@ -651,12 +651,12 @@ cantFindErr cannot_find _ dflags mod_name find_result | otherwise = Outputable.empty mod_hidden pkg = - ptext (sLit "it is a hidden module in the package") <+> quotes (ppr pkg) + text "it is a hidden module in the package" <+> quotes (ppr pkg) pp_suggestions :: [ModuleSuggestion] -> SDoc pp_suggestions sugs | null sugs = Outputable.empty - | otherwise = hang (ptext (sLit "Perhaps you meant")) + | otherwise = hang (text "Perhaps you meant") 2 (vcat (map pp_sugg sugs)) -- NB: Prefer the *original* location, and then reexports, and then @@ -668,14 +668,14 @@ cantFindErr cannot_find _ dflags mod_name find_result fromExposedReexport = res, fromPackageFlag = f }) | Just True <- e - = parens (ptext (sLit "from") <+> ppr (moduleUnitId mod)) + = parens (text "from" <+> ppr (moduleUnitId mod)) | f && moduleName mod == m - = parens (ptext (sLit "from") <+> ppr (moduleUnitId mod)) + = parens (text "from" <+> ppr (moduleUnitId mod)) | (pkg:_) <- res - = parens (ptext (sLit "from") <+> ppr (packageConfigId pkg) - <> comma <+> ptext (sLit "reexporting") <+> ppr mod) + = parens (text "from" <+> ppr (packageConfigId pkg) + <> comma <+> text "reexporting" <+> ppr mod) | f - = parens (ptext (sLit "defined via package flags to be") + = parens (text "defined via package flags to be" <+> ppr mod) | otherwise = Outputable.empty pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o @@ -683,9 +683,9 @@ cantFindErr cannot_find _ dflags mod_name find_result provenance (ModOrigin{ fromOrigPackage = e, fromHiddenReexport = rhs }) | Just False <- e - = parens (ptext (sLit "needs flag -package-key") + = parens (text "needs flag -package-key" <+> ppr (moduleUnitId mod)) | (pkg:_) <- rhs - = parens (ptext (sLit "needs flag -package-id") + = parens (text "needs flag -package-id" <+> ppr (packageConfigId pkg)) | otherwise = Outputable.empty diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 9c6abb89e6..7bbe4be495 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1560,7 +1560,7 @@ warnUnnecessarySourceImports sccs = do warn :: DynFlags -> Located ModuleName -> WarnMsg warn dflags (L loc mod) = mkPlainErrMsg dflags loc - (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ") + (text "Warning: {-# SOURCE #-} unnecessary in import of " <+> quotes (ppr mod)) @@ -2038,8 +2038,8 @@ cyclicModuleErr :: [ModSummary] -> SDoc cyclicModuleErr mss = ASSERT( not (null mss) ) case findCycle graph of - Nothing -> ptext (sLit "Unexpected non-cycle") <+> ppr mss - Just path -> vcat [ ptext (sLit "Module imports form a cycle:") + Nothing -> text "Unexpected non-cycle" <+> ppr mss + Just path -> vcat [ text "Module imports form a cycle:" , nest 2 (show_path path) ] where graph :: [Node NodeKey ModSummary] @@ -2050,14 +2050,14 @@ cyclicModuleErr mss [ (unLoc m, NotBoot) | m <- ms_home_imps ms ]) show_path [] = panic "show_path" - show_path [m] = ptext (sLit "module") <+> ppr_ms m - <+> ptext (sLit "imports itself") - show_path (m1:m2:ms) = vcat ( nest 7 (ptext (sLit "module") <+> ppr_ms m1) - : nest 6 (ptext (sLit "imports") <+> ppr_ms m2) + show_path [m] = text "module" <+> ppr_ms m + <+> text "imports itself" + show_path (m1:m2:ms) = vcat ( nest 7 (text "module" <+> ppr_ms m1) + : nest 6 (text "imports" <+> ppr_ms m2) : go ms ) where - go [] = [ptext (sLit "which imports") <+> ppr_ms m1] - go (m:ms) = (ptext (sLit "which imports") <+> ppr_ms m) : go ms + go [] = [text "which imports" <+> ppr_ms m1] + go (m:ms) = (text "which imports" <+> ppr_ms m) : go ms ppr_ms :: ModSummary -> SDoc diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs index 0b75bc599d..237101bce0 100644 --- a/compiler/main/Hooks.hs +++ b/compiler/main/Hooks.hs @@ -43,10 +43,10 @@ import RdrName import CoreSyn #ifdef GHCI import GHCi.RemoteTypes +import SrcLoc +import Type #endif import BasicTypes -import Type -import SrcLoc import Data.Maybe diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index f8945b2a76..58434e93c6 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -101,6 +101,7 @@ import VarEnv ( emptyTidyEnv ) import THNames ( templateHaskellNames ) import Panic import ConLike +import Control.Concurrent #endif import Module @@ -162,7 +163,6 @@ import Stream (Stream) import Util import Data.List -import Control.Concurrent import Control.Monad import Data.IORef import System.FilePath as FilePath @@ -184,7 +184,9 @@ newHscEnv dflags = do us <- mkSplitUniqSupply 'r' nc_var <- newIORef (initNameCache us allKnownKeyNames) fc_var <- newIORef emptyModuleEnv +#ifdef GHCI iserv_mvar <- newMVar Nothing +#endif return HscEnv { hsc_dflags = dflags , hsc_targets = [] , hsc_mod_graph = [] @@ -1621,7 +1623,7 @@ hscImport hsc_env str = runInteractiveHsc hsc_env $ do [L _ i] -> return i _ -> liftIO $ throwOneError $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $ - ptext (sLit "parse error in import declaration") + text "parse error in import declaration" -- | Typecheck an expression (but don't run it) -- Returns its most general type diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index e8d6d23c0d..6b5458ea79 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -192,13 +192,15 @@ import GHC.Serialized ( Serialized ) import Foreign import Control.Monad ( guard, liftM, when, ap ) -import Control.Concurrent import Data.IORef import Data.Time import Data.Typeable ( Typeable ) import Exception import System.FilePath +#ifdef GHCI +import Control.Concurrent import System.Process ( ProcessHandle ) +#endif -- ----------------------------------------------------------------------------- -- Compilation state @@ -606,8 +608,8 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps , let things = case lookupUFM hpt mod of Just info -> extract info Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg [] - msg = vcat [ptext (sLit "missing module") <+> ppr mod, - ptext (sLit "Probable cause: out-of-date interface files")] + msg = vcat [text "missing module" <+> ppr mod, + text "Probable cause: out-of-date interface files"] -- This really shouldn't happen, but see Trac #962 -- And get its dfuns @@ -2664,20 +2666,20 @@ isNoIfaceVectInfo (IfaceVectInfo l1 l2 l3 l4 l5) instance Outputable VectInfo where ppr info = vcat - [ ptext (sLit "variables :") <+> ppr (vectInfoVar info) - , ptext (sLit "tycons :") <+> ppr (vectInfoTyCon info) - , ptext (sLit "datacons :") <+> ppr (vectInfoDataCon info) - , ptext (sLit "parallel vars :") <+> ppr (vectInfoParallelVars info) - , ptext (sLit "parallel tycons :") <+> ppr (vectInfoParallelTyCons info) + [ text "variables :" <+> ppr (vectInfoVar info) + , text "tycons :" <+> ppr (vectInfoTyCon info) + , text "datacons :" <+> ppr (vectInfoDataCon info) + , text "parallel vars :" <+> ppr (vectInfoParallelVars info) + , text "parallel tycons :" <+> ppr (vectInfoParallelTyCons info) ] instance Outputable IfaceVectInfo where ppr info = vcat - [ ptext (sLit "variables :") <+> ppr (ifaceVectInfoVar info) - , ptext (sLit "tycons :") <+> ppr (ifaceVectInfoTyCon info) - , ptext (sLit "tycons reuse :") <+> ppr (ifaceVectInfoTyConReuse info) - , ptext (sLit "parallel vars :") <+> ppr (ifaceVectInfoParallelVars info) - , ptext (sLit "parallel tycons :") <+> ppr (ifaceVectInfoParallelTyCons info) + [ text "variables :" <+> ppr (ifaceVectInfoVar info) + , text "tycons :" <+> ppr (ifaceVectInfoTyCon info) + , text "tycons reuse :" <+> ppr (ifaceVectInfoTyConReuse info) + , text "parallel vars :" <+> ppr (ifaceVectInfoParallelVars info) + , text "parallel tycons :" <+> ppr (ifaceVectInfoParallelTyCons info) ] @@ -2742,10 +2744,10 @@ numToTrustInfo 4 = setSafeMode Sf_Safe -- retained for backwards compat, used numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" instance Outputable IfaceTrustInfo where - ppr (TrustInfo Sf_None) = ptext $ sLit "none" - ppr (TrustInfo Sf_Unsafe) = ptext $ sLit "unsafe" - ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy" - ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe" + ppr (TrustInfo Sf_None) = text "none" + ppr (TrustInfo Sf_Unsafe) = text "unsafe" + ppr (TrustInfo Sf_Trustworthy) = text "trustworthy" + ppr (TrustInfo Sf_Safe) = text "safe" instance Binary IfaceTrustInfo where put_ bh iftrust = putByte bh $ trustInfoToNum iftrust diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs index e22bf93656..cf181046f0 100644 --- a/compiler/main/Packages.hs +++ b/compiler/main/Packages.hs @@ -722,17 +722,17 @@ findWiredInPackages dflags pkgs vis_map = do where notfound = do debugTraceMsg dflags 2 $ - ptext (sLit "wired-in package ") + text "wired-in package " <> text wired_pkg - <> ptext (sLit " not found.") + <> text " not found." return Nothing pick :: PackageConfig -> IO (Maybe PackageConfig) pick pkg = do debugTraceMsg dflags 2 $ - ptext (sLit "wired-in package ") + text "wired-in package " <> text wired_pkg - <> ptext (sLit " mapped to ") + <> text " mapped to " <> ppr (unitId pkg) return (Just pkg) @@ -801,7 +801,7 @@ type UnusablePackages = Map UnitId pprReason :: SDoc -> UnusablePackageReason -> SDoc pprReason pref reason = case reason of IgnoredWithFlag -> - pref <+> ptext (sLit "ignored due to an -ignore-package flag") + pref <+> text "ignored due to an -ignore-package flag" MissingDependencies is_shadowed deps -> pref <+> text "unusable due to" <+> (if is_shadowed then text "shadowed" @@ -815,7 +815,7 @@ reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs) report (ipid, (_, reason)) = debugTraceMsg dflags 2 $ pprReason - (ptext (sLit "package") <+> ppr ipid <+> text "is") reason + (text "package" <+> ppr ipid <+> text "is") reason -- ---------------------------------------------------------------------------- -- @@ -1445,12 +1445,12 @@ add_package pkg_db ps (p, mb_parent) = add_package pkg_db ps (key, Just p) missingPackageMsg :: Outputable pkgid => pkgid -> SDoc -missingPackageMsg p = ptext (sLit "unknown package:") <+> ppr p +missingPackageMsg p = text "unknown package:" <+> ppr p missingDependencyMsg :: Maybe UnitId -> SDoc missingDependencyMsg Nothing = Outputable.empty missingDependencyMsg (Just parent) - = space <> parens (ptext (sLit "dependency of") <+> ftext (unitIdFS parent)) + = space <> parens (text "dependency of" <+> ftext (unitIdFS parent)) -- ----------------------------------------------------------------------------- diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index d55b5083ec..e738d7a4fe 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -30,7 +30,6 @@ import TcType import Name import VarEnv( emptyTidyEnv ) import Outputable -import FastString -- ----------------------------------------------------------------------------- -- Pretty-printing entities that we get from the GHC API @@ -88,7 +87,7 @@ pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc }) pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom , fi_tys = lhs_tys, fi_rhs = rhs }) = showWithLoc (pprDefinedAt (getName axiom)) $ - hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys) + hang (text "type instance" <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys) 2 (equals <+> ppr rhs) ---------------------------- @@ -162,4 +161,4 @@ showWithLoc loc doc = hang doc 2 (char '\t' <> comment <+> loc) -- The tab tries to make them line up a bit where - comment = ptext (sLit "--") + comment = text "--" diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs index 4166b9b43a..c3436edd9e 100644 --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -1218,8 +1218,8 @@ removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO () removeWith dflags remover f = remover f `catchIO` (\e -> let msg = if isDoesNotExistError e - then ptext (sLit "Warning: deleting non-existent") <+> text f - else ptext (sLit "Warning: exception raised when deleting") + then text "Warning: deleting non-existent" <+> text f + else text "Warning: exception raised when deleting" <+> text f <> colon $$ text (show e) in debugTraceMsg dflags 2 msg @@ -1456,7 +1456,7 @@ traceCmd dflags phase_name cmd_line action } where handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n') - ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn)) + ; debugTraceMsg dflags 2 (text "Failed:" <+> text cmd_line <+> text (show exn)) ; throwGhcExceptionIO (ProgramError (show exn))} {- diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index 8a27fd7b6e..59cb201e8a 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -57,7 +57,6 @@ import UniqSupply import ErrUtils (Severity(..)) import Outputable import SrcLoc -import FastString import qualified ErrUtils as Err import Control.Monad @@ -385,14 +384,14 @@ tidyProgram hsc_env (ModGuts { mg_module = mod -- on, print now ; unless (dopt Opt_D_dump_simpl dflags) $ Err.dumpIfSet_dyn dflags Opt_D_dump_rules - (showSDoc dflags (ppr CoreTidy <+> ptext (sLit "rules"))) + (showSDoc dflags (ppr CoreTidy <+> text "rules")) (pprRulesForUser tidy_rules) -- Print one-line size info ; let cs = coreBindsStats tidy_binds ; when (dopt Opt_D_dump_core_stats dflags) (log_action dflags dflags SevDump noSrcSpan defaultDumpStyle - (ptext (sLit "Tidy size (terms,types,coercions)") + (text "Tidy size (terms,types,coercions)" <+> ppr (moduleName mod) <> colon <+> int (cs_tm cs) <+> int (cs_ty cs) diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs index fc18c6bbe1..6bb7f8a875 100644 --- a/compiler/nativeGen/AsmCodeGen.hs +++ b/compiler/nativeGen/AsmCodeGen.hs @@ -433,7 +433,7 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap us -- used. Note that it is important that we generate these in -- ascending order, as Clang's 3.6 assembler complains. let newFileIds = sortBy (comparing snd) $ eltsUFM $ fileIds' `minusUFM` fileIds - pprDecl (f,n) = ptext (sLit "\t.file ") <> ppr n <+> + pprDecl (f,n) = text "\t.file " <> ppr n <+> doubleQuotes (ftext f) emitNativeCode dflags h $ vcat $ diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs index 54422ec299..3b299746a9 100644 --- a/compiler/nativeGen/Dwarf.hs +++ b/compiler/nativeGen/Dwarf.hs @@ -8,7 +8,6 @@ import Config ( cProjectName, cProjectVersion ) import CoreSyn ( Tickish(..) ) import Debug import DynFlags -import FastString import Module import Outputable import Platform @@ -107,13 +106,13 @@ compileUnitHeader :: Unique -> SDoc compileUnitHeader unitU = sdocWithPlatform $ \plat -> let cuLabel = mkAsmTempLabel unitU -- sits right before initialLength field length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel - <> ptext (sLit "-4") -- length of initialLength field + <> text "-4" -- length of initialLength field in vcat [ ppr cuLabel <> colon - , ptext (sLit "\t.long ") <> length -- compilation unit size + , text "\t.long " <> length -- compilation unit size , pprHalf 3 -- DWARF version , sectionOffset (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel) -- abbrevs offset - , ptext (sLit "\t.byte ") <> ppr (platformWordSize plat) -- word size + , text "\t.byte " <> ppr (platformWordSize plat) -- word size ] -- | Compilation unit footer, mainly establishing size of debug sections diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs index e80f2a104f..e0214e568a 100644 --- a/compiler/nativeGen/Dwarf/Types.hs +++ b/compiler/nativeGen/Dwarf/Types.hs @@ -296,7 +296,7 @@ pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs} in vcat [ ppr cieLabel <> colon , pprData4' length -- Length of CIE , ppr cieStartLabel <> colon - , pprData4' (ptext (sLit "-1")) + , pprData4' (text "-1") -- Common Information Entry marker (-1 = 0xf..f) , pprByte 3 -- CIE version (we require DWARF 3) , pprByte 0 -- Augmentation (none) @@ -449,9 +449,9 @@ pprUnwindExpr spIsCFA expr pprE (UwPlus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus pprE (UwMinus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus pprE (UwTimes u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul - in ptext (sLit "\t.uleb128 1f-.-1") $$ -- DW_FORM_block length + in text "\t.uleb128 1f-.-1" $$ -- DW_FORM_block length pprE expr $$ - ptext (sLit "1:") + text "1:" -- | Generate code for re-setting the unwind information for a -- register to @undefined@ @@ -464,7 +464,7 @@ pprUndefUnwind plat g = pprByte dW_CFA_undefined $$ -- | Align assembly at (machine) word boundary wordAlign :: SDoc wordAlign = sdocWithPlatform $ \plat -> - ptext (sLit "\t.align ") <> case platformOS plat of + text "\t.align " <> case platformOS plat of OSDarwin -> case platformWordSize plat of 8 -> text "3" 4 -> text "2" @@ -473,7 +473,7 @@ wordAlign = sdocWithPlatform $ \plat -> -- | Assembly for a single byte of constant DWARF data pprByte :: Word8 -> SDoc -pprByte x = ptext (sLit "\t.byte ") <> ppr (fromIntegral x :: Word) +pprByte x = text "\t.byte " <> ppr (fromIntegral x :: Word) -- | Assembly for a two-byte constant integer pprHalf :: Word16 -> SDoc @@ -492,7 +492,7 @@ pprFlag f = pprByte (if f then 0xff else 0x00) -- | Assembly for 4 bytes of dynamic DWARF data pprData4' :: SDoc -> SDoc -pprData4' x = ptext (sLit "\t.long ") <> x +pprData4' x = text "\t.long " <> x -- | Assembly for 4 bytes of constant DWARF data pprData4 :: Word -> SDoc @@ -508,8 +508,8 @@ pprDwWord = pprData4' pprWord :: SDoc -> SDoc pprWord s = (<> s) . sdocWithPlatform $ \plat -> case platformWordSize plat of - 4 -> ptext (sLit "\t.long ") - 8 -> ptext (sLit "\t.quad ") + 4 -> text "\t.long " + 8 -> text "\t.quad " n -> panic $ "pprWord: Unsupported target platform word length " ++ show n ++ "!" @@ -532,7 +532,7 @@ pprLEBInt x | x >= -64 && x < 64 -- | Generates a dynamic null-terminated string. If required the -- caller needs to make sure that the string is escaped properly. pprString' :: SDoc -> SDoc -pprString' str = ptext (sLit "\t.asciz \"") <> str <> char '"' +pprString' str = text "\t.asciz \"" <> str <> char '"' -- | Generate a string constant. We take care to escape the string. pprString :: String -> SDoc @@ -544,9 +544,9 @@ pprString str -- | Escape a single non-unicode character escapeChar :: Char -> SDoc -escapeChar '\\' = ptext (sLit "\\\\") -escapeChar '\"' = ptext (sLit "\\\"") -escapeChar '\n' = ptext (sLit "\\n") +escapeChar '\\' = text "\\\\" +escapeChar '\"' = text "\\\"" +escapeChar '\n' = text "\\n" escapeChar c | isAscii c && isPrint c && c /= '?' -- prevents trigraph warnings = char c diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index fa726dddd1..5cb90ad2a4 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -473,26 +473,26 @@ pprGotDeclaration :: DynFlags -> Arch -> OS -> SDoc pprGotDeclaration dflags ArchX86 OSDarwin | gopt Opt_PIC dflags = vcat [ - ptext (sLit ".section __TEXT,__textcoal_nt,coalesced,no_toc"), - ptext (sLit ".weak_definition ___i686.get_pc_thunk.ax"), - ptext (sLit ".private_extern ___i686.get_pc_thunk.ax"), - ptext (sLit "___i686.get_pc_thunk.ax:"), - ptext (sLit "\tmovl (%esp), %eax"), - ptext (sLit "\tret") ] + text ".section __TEXT,__textcoal_nt,coalesced,no_toc", + text ".weak_definition ___i686.get_pc_thunk.ax", + text ".private_extern ___i686.get_pc_thunk.ax", + text "___i686.get_pc_thunk.ax:", + text "\tmovl (%esp), %eax", + text "\tret" ] pprGotDeclaration _ _ OSDarwin = empty -- PPC 64 ELF v1needs a Table Of Contents (TOC) on Linux pprGotDeclaration _ (ArchPPC_64 ELF_V1) OSLinux - = ptext (sLit ".section \".toc\",\"aw\"") + = text ".section \".toc\",\"aw\"" -- In ELF v2 we also need to tell the assembler that we want ABI -- version 2. This would normally be done at the top of the file -- right after a file directive, but I could not figure out how -- to do that. pprGotDeclaration _ (ArchPPC_64 ELF_V2) OSLinux - = vcat [ ptext (sLit ".abiversion 2"), - ptext (sLit ".section \".toc\",\"aw\"") + = vcat [ text ".abiversion 2", + text ".section \".toc\",\"aw\"" ] pprGotDeclaration _ (ArchPPC_64 _) _ = panic "pprGotDeclaration: ArchPPC_64 only Linux supported" @@ -509,8 +509,8 @@ pprGotDeclaration dflags arch os , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 = vcat [ -- See Note [.LCTOC1 in PPC PIC code] - ptext (sLit ".section \".got2\",\"aw\""), - ptext (sLit ".LCTOC1 = .+32768") ] + text ".section \".got2\",\"aw\"", + text ".LCTOC1 = .+32768" ] pprGotDeclaration _ _ _ = panic "pprGotDeclaration: no match" @@ -530,50 +530,50 @@ pprImportedSymbol dflags platform@(Platform { platformArch = ArchPPC, platformOS = case gopt Opt_PIC dflags of False -> vcat [ - ptext (sLit ".symbol_stub"), - ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$stub:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, - ptext (sLit "\tlis r11,ha16(L") <> pprCLabel platform lbl - <> ptext (sLit "$lazy_ptr)"), - ptext (sLit "\tlwz r12,lo16(L") <> pprCLabel platform lbl - <> ptext (sLit "$lazy_ptr)(r11)"), - ptext (sLit "\tmtctr r12"), - ptext (sLit "\taddi r11,r11,lo16(L") <> pprCLabel platform lbl - <> ptext (sLit "$lazy_ptr)"), - ptext (sLit "\tbctr") + text ".symbol_stub", + text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"), + text "\t.indirect_symbol" <+> pprCLabel platform lbl, + text "\tlis r11,ha16(L" <> pprCLabel platform lbl + <> text "$lazy_ptr)", + text "\tlwz r12,lo16(L" <> pprCLabel platform lbl + <> text "$lazy_ptr)(r11)", + text "\tmtctr r12", + text "\taddi r11,r11,lo16(L" <> pprCLabel platform lbl + <> text "$lazy_ptr)", + text "\tbctr" ] True -> vcat [ - ptext (sLit ".section __TEXT,__picsymbolstub1,") - <> ptext (sLit "symbol_stubs,pure_instructions,32"), - ptext (sLit "\t.align 2"), - ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$stub:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, - ptext (sLit "\tmflr r0"), - ptext (sLit "\tbcl 20,31,L0$") <> pprCLabel platform lbl, - ptext (sLit "L0$") <> pprCLabel platform lbl <> char ':', - ptext (sLit "\tmflr r11"), - ptext (sLit "\taddis r11,r11,ha16(L") <> pprCLabel platform lbl - <> ptext (sLit "$lazy_ptr-L0$") <> pprCLabel platform lbl <> char ')', - ptext (sLit "\tmtlr r0"), - ptext (sLit "\tlwzu r12,lo16(L") <> pprCLabel platform lbl - <> ptext (sLit "$lazy_ptr-L0$") <> pprCLabel platform lbl - <> ptext (sLit ")(r11)"), - ptext (sLit "\tmtctr r12"), - ptext (sLit "\tbctr") + text ".section __TEXT,__picsymbolstub1," + <> text "symbol_stubs,pure_instructions,32", + text "\t.align 2", + text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"), + text "\t.indirect_symbol" <+> pprCLabel platform lbl, + text "\tmflr r0", + text "\tbcl 20,31,L0$" <> pprCLabel platform lbl, + text "L0$" <> pprCLabel platform lbl <> char ':', + text "\tmflr r11", + text "\taddis r11,r11,ha16(L" <> pprCLabel platform lbl + <> text "$lazy_ptr-L0$" <> pprCLabel platform lbl <> char ')', + text "\tmtlr r0", + text "\tlwzu r12,lo16(L" <> pprCLabel platform lbl + <> text "$lazy_ptr-L0$" <> pprCLabel platform lbl + <> text ")(r11)", + text "\tmtctr r12", + text "\tbctr" ] $+$ vcat [ - ptext (sLit ".lazy_symbol_pointer"), - ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, - ptext (sLit "\t.long dyld_stub_binding_helper")] + text ".lazy_symbol_pointer", + text "L" <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"), + text "\t.indirect_symbol" <+> pprCLabel platform lbl, + text "\t.long dyld_stub_binding_helper"] | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl = vcat [ - ptext (sLit ".non_lazy_symbol_pointer"), - char 'L' <> pprCLabel platform lbl <> ptext (sLit "$non_lazy_ptr:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, - ptext (sLit "\t.long\t0")] + text ".non_lazy_symbol_pointer", + char 'L' <> pprCLabel platform lbl <> text "$non_lazy_ptr:", + text "\t.indirect_symbol" <+> pprCLabel platform lbl, + text "\t.long\t0"] | otherwise = empty @@ -584,49 +584,49 @@ pprImportedSymbol dflags platform@(Platform { platformArch = ArchX86, platformOS = case gopt Opt_PIC dflags of False -> vcat [ - ptext (sLit ".symbol_stub"), - ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$stub:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, - ptext (sLit "\tjmp *L") <> pprCLabel platform lbl - <> ptext (sLit "$lazy_ptr"), - ptext (sLit "L") <> pprCLabel platform lbl - <> ptext (sLit "$stub_binder:"), - ptext (sLit "\tpushl $L") <> pprCLabel platform lbl - <> ptext (sLit "$lazy_ptr"), - ptext (sLit "\tjmp dyld_stub_binding_helper") + text ".symbol_stub", + text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"), + text "\t.indirect_symbol" <+> pprCLabel platform lbl, + text "\tjmp *L" <> pprCLabel platform lbl + <> text "$lazy_ptr", + text "L" <> pprCLabel platform lbl + <> text "$stub_binder:", + text "\tpushl $L" <> pprCLabel platform lbl + <> text "$lazy_ptr", + text "\tjmp dyld_stub_binding_helper" ] True -> vcat [ - ptext (sLit ".section __TEXT,__picsymbolstub2,") - <> ptext (sLit "symbol_stubs,pure_instructions,25"), - ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$stub:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, - ptext (sLit "\tcall ___i686.get_pc_thunk.ax"), - ptext (sLit "1:"), - ptext (sLit "\tmovl L") <> pprCLabel platform lbl - <> ptext (sLit "$lazy_ptr-1b(%eax),%edx"), - ptext (sLit "\tjmp *%edx"), - ptext (sLit "L") <> pprCLabel platform lbl - <> ptext (sLit "$stub_binder:"), - ptext (sLit "\tlea L") <> pprCLabel platform lbl - <> ptext (sLit "$lazy_ptr-1b(%eax),%eax"), - ptext (sLit "\tpushl %eax"), - ptext (sLit "\tjmp dyld_stub_binding_helper") + text ".section __TEXT,__picsymbolstub2," + <> text "symbol_stubs,pure_instructions,25", + text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"), + text "\t.indirect_symbol" <+> pprCLabel platform lbl, + text "\tcall ___i686.get_pc_thunk.ax", + text "1:", + text "\tmovl L" <> pprCLabel platform lbl + <> text "$lazy_ptr-1b(%eax),%edx", + text "\tjmp *%edx", + text "L" <> pprCLabel platform lbl + <> text "$stub_binder:", + text "\tlea L" <> pprCLabel platform lbl + <> text "$lazy_ptr-1b(%eax),%eax", + text "\tpushl %eax", + text "\tjmp dyld_stub_binding_helper" ] - $+$ vcat [ ptext (sLit ".section __DATA, __la_sym_ptr") + $+$ vcat [ text ".section __DATA, __la_sym_ptr" <> (if gopt Opt_PIC dflags then int 2 else int 3) - <> ptext (sLit ",lazy_symbol_pointers"), - ptext (sLit "L") <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, - ptext (sLit "\t.long L") <> pprCLabel platform lbl - <> ptext (sLit "$stub_binder")] + <> text ",lazy_symbol_pointers", + text "L" <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"), + text "\t.indirect_symbol" <+> pprCLabel platform lbl, + text "\t.long L" <> pprCLabel platform lbl + <> text "$stub_binder"] | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl = vcat [ - ptext (sLit ".non_lazy_symbol_pointer"), - char 'L' <> pprCLabel platform lbl <> ptext (sLit "$non_lazy_ptr:"), - ptext (sLit "\t.indirect_symbol") <+> pprCLabel platform lbl, - ptext (sLit "\t.long\t0")] + text ".non_lazy_symbol_pointer", + char 'L' <> pprCLabel platform lbl <> text "$non_lazy_ptr:", + text "\t.indirect_symbol" <+> pprCLabel platform lbl, + text "\t.long\t0"] | otherwise = empty @@ -671,9 +671,9 @@ pprImportedSymbol _ platform@(Platform { platformArch = ArchPPC_64 _ }) = case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) -> vcat [ - ptext (sLit ".section \".toc\", \"aw\""), - ptext (sLit ".LC_") <> pprCLabel platform lbl <> char ':', - ptext (sLit "\t.quad") <+> pprCLabel platform lbl ] + text ".section \".toc\", \"aw\"", + text ".LC_" <> pprCLabel platform lbl <> char ':', + text "\t.quad" <+> pprCLabel platform lbl ] _ -> empty pprImportedSymbol dflags platform importedLbl @@ -686,8 +686,8 @@ pprImportedSymbol dflags platform importedLbl _ -> panic "Unknown wordRep in pprImportedSymbol" in vcat [ - ptext (sLit ".section \".got2\", \"aw\""), - ptext (sLit ".LC_") <> pprCLabel platform lbl <> char ':', + text ".section \".got2\", \"aw\"", + text ".LC_" <> pprCLabel platform lbl <> char ':', ptext symbolSize <+> pprCLabel platform lbl ] -- PLT code stubs are generated automatically by the dynamic linker. diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index b8fe838c7a..8d89a193a4 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -126,21 +126,21 @@ pprData (CmmString str) = pprASCII str pprData (CmmUninitialised bytes) = keyword <> int bytes where keyword = sdocWithPlatform $ \platform -> case platformOS platform of - OSDarwin -> ptext (sLit ".space ") - _ -> ptext (sLit ".skip ") + OSDarwin -> text ".space " + _ -> text ".skip " pprData (CmmStaticLit lit) = pprDataItem lit pprGloblDecl :: CLabel -> SDoc pprGloblDecl lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = ptext (sLit ".globl ") <> ppr lbl + | otherwise = text ".globl " <> ppr lbl pprTypeAndSizeDecl :: CLabel -> SDoc pprTypeAndSizeDecl lbl = sdocWithPlatform $ \platform -> if platformOS platform == OSLinux && externallyVisibleCLabel lbl - then ptext (sLit ".type ") <> - ppr lbl <> ptext (sLit ", @object") + then text ".type " <> + ppr lbl <> text ", @object" else empty pprLabel :: CLabel -> SDoc @@ -154,7 +154,7 @@ pprASCII str = vcat (map do1 str) $$ do1 0 where do1 :: Word8 -> SDoc - do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) + do1 w = text "\t.byte\t" <> int (fromIntegral w) -- ----------------------------------------------------------------------------- @@ -220,7 +220,7 @@ pprReg r _ | i <= 31 -> int i -- GPRs | i <= 63 -> int (i-32) -- FPRs - | otherwise -> ptext (sLit "very naughty powerpc register") + | otherwise -> text "very naughty powerpc register" @@ -255,8 +255,8 @@ pprImm (ImmCLbl l) = ppr l pprImm (ImmIndex l i) = ppr l <> char '+' <> int i pprImm (ImmLit s) = s -pprImm (ImmFloat _) = ptext (sLit "naughty float immediate") -pprImm (ImmDouble _) = ptext (sLit "naughty double immediate") +pprImm (ImmFloat _) = text "naughty float immediate" +pprImm (ImmDouble _) = text "naughty double immediate" pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b pprImm (ImmConstantDiff a b) = pprImm a <> char '-' @@ -295,7 +295,7 @@ pprImm (HIGHESTA i) pprAddr :: AddrMode -> SDoc pprAddr (AddrRegReg r1 r2) - = pprReg r1 <+> ptext (sLit ", ") <+> pprReg r2 + = pprReg r1 <+> text ", " <+> pprReg r2 pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ] pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ] @@ -338,30 +338,30 @@ pprDataItem lit imm = litToImm lit archPPC_64 dflags = not $ target32Bit $ targetPlatform dflags - ppr_item II8 _ _ = [ptext (sLit "\t.byte\t") <> pprImm imm] + ppr_item II8 _ _ = [text "\t.byte\t" <> pprImm imm] - ppr_item II32 _ _ = [ptext (sLit "\t.long\t") <> pprImm imm] + ppr_item II32 _ _ = [text "\t.long\t" <> pprImm imm] ppr_item II64 _ dflags - | archPPC_64 dflags = [ptext (sLit "\t.quad\t") <> pprImm imm] + | archPPC_64 dflags = [text "\t.quad\t" <> pprImm imm] ppr_item FF32 (CmmFloat r _) _ = let bs = floatToBytes (fromRational r) - in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs + in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs ppr_item FF64 (CmmFloat r _) _ = let bs = doubleToBytes (fromRational r) - in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs + in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs - ppr_item II16 _ _ = [ptext (sLit "\t.short\t") <> pprImm imm] + ppr_item II16 _ _ = [text "\t.short\t" <> pprImm imm] ppr_item II64 (CmmInt x _) dflags | not(archPPC_64 dflags) = - [ptext (sLit "\t.long\t") + [text "\t.long\t" <> int (fromIntegral (fromIntegral (x `shiftR` 32) :: Word32)), - ptext (sLit "\t.long\t") + text "\t.long\t" <> int (fromIntegral (fromIntegral x :: Word32))] ppr_item _ _ _ @@ -374,8 +374,8 @@ pprInstr (COMMENT _) = empty -- nuke 'em {- pprInstr (COMMENT s) = if platformOS platform == OSLinux - then ptext (sLit "# ") <> ftext s - else ptext (sLit "; ") <> ftext s + then text "# " <> ftext s + else text "; " <> ftext s -} pprInstr (DELTA d) = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) @@ -389,24 +389,24 @@ pprInstr (LDATA _ _) {- pprInstr (SPILL reg slot) = hcat [ - ptext (sLit "\tSPILL"), + text "\tSPILL", char '\t', pprReg reg, comma, - ptext (sLit "SLOT") <> parens (int slot)] + text "SLOT" <> parens (int slot)] pprInstr (RELOAD slot reg) = hcat [ - ptext (sLit "\tRELOAD"), + text "\tRELOAD", char '\t', - ptext (sLit "SLOT") <> parens (int slot), + text "SLOT" <> parens (int slot), comma, pprReg reg] -} pprInstr (LD fmt reg addr) = hcat [ char '\t', - ptext (sLit "l"), + text "l", ptext (case fmt of II8 -> sLit "bz" II16 -> sLit "hz" @@ -420,7 +420,7 @@ pprInstr (LD fmt reg addr) = hcat [ AddrRegReg _ _ -> char 'x', char '\t', pprReg reg, - ptext (sLit ", "), + text ", ", pprAddr addr ] pprInstr (LDFAR fmt reg (AddrRegImm source off)) = @@ -434,7 +434,7 @@ pprInstr (LDFAR _ _ _) = pprInstr (LA fmt reg addr) = hcat [ char '\t', - ptext (sLit "l"), + text "l", ptext (case fmt of II8 -> sLit "ba" II16 -> sLit "ha" @@ -448,18 +448,18 @@ pprInstr (LA fmt reg addr) = hcat [ AddrRegReg _ _ -> char 'x', char '\t', pprReg reg, - ptext (sLit ", "), + text ", ", pprAddr addr ] pprInstr (ST fmt reg addr) = hcat [ char '\t', - ptext (sLit "st"), + text "st", pprFormat fmt, case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', char '\t', pprReg reg, - ptext (sLit ", "), + text ", ", pprAddr addr ] pprInstr (STFAR fmt reg (AddrRegImm source off)) = @@ -472,29 +472,29 @@ pprInstr (STFAR _ _ _) = panic "PPC.Ppr.pprInstr STFAR: no match" pprInstr (STU fmt reg addr) = hcat [ char '\t', - ptext (sLit "st"), + text "st", pprFormat fmt, - ptext (sLit "u\t"), + text "u\t", case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x', pprReg reg, - ptext (sLit ", "), + text ", ", pprAddr addr ] pprInstr (LIS reg imm) = hcat [ char '\t', - ptext (sLit "lis"), + text "lis", char '\t', pprReg reg, - ptext (sLit ", "), + text ", ", pprImm imm ] pprInstr (LI reg imm) = hcat [ char '\t', - ptext (sLit "li"), + text "li", char '\t', pprReg reg, - ptext (sLit ", "), + text ", ", pprImm imm ] pprInstr (MR reg1 reg2) @@ -503,11 +503,11 @@ pprInstr (MR reg1 reg2) char '\t', sdocWithPlatform $ \platform -> case targetClassOfReg platform reg1 of - RcInteger -> ptext (sLit "mr") - _ -> ptext (sLit "fmr"), + RcInteger -> text "mr" + _ -> text "fmr", char '\t', pprReg reg1, - ptext (sLit ", "), + text ", ", pprReg reg2 ] pprInstr (CMP fmt reg ri) = hcat [ @@ -515,12 +515,12 @@ pprInstr (CMP fmt reg ri) = hcat [ op, char '\t', pprReg reg, - ptext (sLit ", "), + text ", ", pprRI ri ] where op = hcat [ - ptext (sLit "cmp"), + text "cmp", pprFormat fmt, case ri of RIReg _ -> empty @@ -531,12 +531,12 @@ pprInstr (CMPL fmt reg ri) = hcat [ op, char '\t', pprReg reg, - ptext (sLit ", "), + text ", ", pprRI ri ] where op = hcat [ - ptext (sLit "cmpl"), + text "cmpl", pprFormat fmt, case ri of RIReg _ -> empty @@ -544,7 +544,7 @@ pprInstr (CMPL fmt reg ri) = hcat [ ] pprInstr (BCC cond blockid) = hcat [ char '\t', - ptext (sLit "b"), + text "b", pprCond cond, char '\t', ppr lbl @@ -553,12 +553,12 @@ pprInstr (BCC cond blockid) = hcat [ pprInstr (BCCFAR cond blockid) = vcat [ hcat [ - ptext (sLit "\tb"), + text "\tb", pprCond (condNegate cond), - ptext (sLit "\t$+8") + text "\t$+8" ], hcat [ - ptext (sLit "\tb\t"), + text "\tb\t", ppr lbl ] ] @@ -566,48 +566,48 @@ pprInstr (BCCFAR cond blockid) = vcat [ pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel char '\t', - ptext (sLit "b"), + text "b", char '\t', ppr lbl ] pprInstr (MTCTR reg) = hcat [ char '\t', - ptext (sLit "mtctr"), + text "mtctr", char '\t', pprReg reg ] pprInstr (BCTR _ _) = hcat [ char '\t', - ptext (sLit "bctr") + text "bctr" ] pprInstr (BL lbl _) = hcat [ - ptext (sLit "\tbl\t"), + text "\tbl\t", ppr lbl ] pprInstr (BCTRL _) = hcat [ char '\t', - ptext (sLit "bctrl") + text "bctrl" ] pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri pprInstr (ADDI reg1 reg2 imm) = hcat [ char '\t', - ptext (sLit "addi"), + text "addi", char '\t', pprReg reg1, - ptext (sLit ", "), + text ", ", pprReg reg2, - ptext (sLit ", "), + text ", ", pprImm imm ] pprInstr (ADDIS reg1 reg2 imm) = hcat [ char '\t', - ptext (sLit "addis"), + text "addis", char '\t', pprReg reg1, - ptext (sLit ", "), + text ", ", pprReg reg2, - ptext (sLit ", "), + text ", ", pprImm imm ] @@ -626,34 +626,34 @@ pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3) pprInstr (DIVDU reg1 reg2 reg3) = pprLogic (sLit "divdu") reg1 reg2 (RIReg reg3) pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [ - hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "), - pprReg reg2, ptext (sLit ", "), + hcat [ text "\tmullwo\t", pprReg reg1, ptext (sLit ", "), + pprReg reg2, text ", ", pprReg reg3 ], - hcat [ ptext (sLit "\tmfxer\t"), pprReg reg1 ], - hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "), - pprReg reg1, ptext (sLit ", "), - ptext (sLit "2, 31, 31") ] + hcat [ text "\tmfxer\t", pprReg reg1 ], + hcat [ text "\trlwinm\t", pprReg reg1, ptext (sLit ", "), + pprReg reg1, text ", ", + text "2, 31, 31" ] ] pprInstr (MULLD_MayOflo reg1 reg2 reg3) = vcat [ - hcat [ ptext (sLit "\tmulldo\t"), pprReg reg1, ptext (sLit ", "), - pprReg reg2, ptext (sLit ", "), + hcat [ text "\tmulldo\t", pprReg reg1, ptext (sLit ", "), + pprReg reg2, text ", ", pprReg reg3 ], - hcat [ ptext (sLit "\tmfxer\t"), pprReg reg1 ], - hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "), - pprReg reg1, ptext (sLit ", "), - ptext (sLit "2, 31, 31") ] + hcat [ text "\tmfxer\t", pprReg reg1 ], + hcat [ text "\trlwinm\t", pprReg reg1, ptext (sLit ", "), + pprReg reg1, text ", ", + text "2, 31, 31" ] ] -- for some reason, "andi" doesn't exist. -- we'll use "andi." instead. pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [ char '\t', - ptext (sLit "andi."), + text "andi.", char '\t', pprReg reg1, - ptext (sLit ", "), + text ", ", pprReg reg2, - ptext (sLit ", "), + text ", ", pprImm imm ] pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri @@ -663,33 +663,33 @@ pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri pprInstr (ORIS reg1 reg2 imm) = hcat [ char '\t', - ptext (sLit "oris"), + text "oris", char '\t', pprReg reg1, - ptext (sLit ", "), + text ", ", pprReg reg2, - ptext (sLit ", "), + text ", ", pprImm imm ] pprInstr (XORIS reg1 reg2 imm) = hcat [ char '\t', - ptext (sLit "xoris"), + text "xoris", char '\t', pprReg reg1, - ptext (sLit ", "), + text ", ", pprReg reg2, - ptext (sLit ", "), + text ", ", pprImm imm ] pprInstr (EXTS fmt reg1 reg2) = hcat [ char '\t', - ptext (sLit "exts"), + text "exts", pprFormat fmt, char '\t', pprReg reg1, - ptext (sLit ", "), + text ", ", pprReg reg2 ] @@ -738,15 +738,15 @@ pprInstr (SRA fmt reg1 reg2 ri) = in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [ - ptext (sLit "\trlwinm\t"), + text "\trlwinm\t", pprReg reg1, - ptext (sLit ", "), + text ", ", pprReg reg2, - ptext (sLit ", "), + text ", ", int sh, - ptext (sLit ", "), + text ", ", int mb, - ptext (sLit ", "), + text ", ", int me ] @@ -758,12 +758,12 @@ pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2 pprInstr (FCMP reg1 reg2) = hcat [ char '\t', - ptext (sLit "fcmpu\tcr0, "), + text "fcmpu\tcr0, ", -- Note: we're using fcmpu, not fcmpo -- The difference is with fcmpo, compare with NaN is an invalid operation. -- We don't handle invalid fp ops, so we don't care pprReg reg1, - ptext (sLit ", "), + text ", ", pprReg reg2 ] @@ -773,48 +773,48 @@ pprInstr (FCFID reg1 reg2) = pprUnary (sLit "fcfid") reg1 reg2 pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2 pprInstr (CRNOR dst src1 src2) = hcat [ - ptext (sLit "\tcrnor\t"), + text "\tcrnor\t", int dst, - ptext (sLit ", "), + text ", ", int src1, - ptext (sLit ", "), + text ", ", int src2 ] pprInstr (MFCR reg) = hcat [ char '\t', - ptext (sLit "mfcr"), + text "mfcr", char '\t', pprReg reg ] pprInstr (MFLR reg) = hcat [ char '\t', - ptext (sLit "mflr"), + text "mflr", char '\t', pprReg reg ] pprInstr (FETCHPC reg) = vcat [ - ptext (sLit "\tbcl\t20,31,1f"), - hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ] + text "\tbcl\t20,31,1f", + hcat [ text "1:\tmflr\t", pprReg reg ] ] pprInstr (FETCHTOC reg lab) = vcat [ - hcat [ ptext (sLit "0:\taddis\t"), pprReg reg, - ptext (sLit ",12,.TOC.-0b@ha") ], - hcat [ ptext (sLit "\taddi\t"), pprReg reg, + hcat [ text "0:\taddis\t", pprReg reg, + text ",12,.TOC.-0b@ha" ], + hcat [ text "\taddi\t", pprReg reg, char ',', pprReg reg, - ptext (sLit ",.TOC.-0b@l") ], - hcat [ ptext (sLit "\t.localentry\t"), + text ",.TOC.-0b@l" ], + hcat [ text "\t.localentry\t", ppr lab, - ptext (sLit ",.-"), + text ",.-", ppr lab] ] -pprInstr LWSYNC = ptext (sLit "\tlwsync") +pprInstr LWSYNC = text "\tlwsync" -pprInstr NOP = ptext (sLit "\tnop") +pprInstr NOP = text "\tnop" pprInstr (UPDATE_SP fmt amount@(ImmInt offset)) | fits16Bits offset = vcat [ @@ -844,9 +844,9 @@ pprLogic op reg1 reg2 ri = hcat [ RIImm _ -> char 'i', char '\t', pprReg reg1, - ptext (sLit ", "), + text ", ", pprReg reg2, - ptext (sLit ", "), + text ", ", pprRI ri ] @@ -857,7 +857,7 @@ pprUnary op reg1 reg2 = hcat [ ptext op, char '\t', pprReg reg1, - ptext (sLit ", "), + text ", ", pprReg reg2 ] @@ -869,9 +869,9 @@ pprBinaryF op fmt reg1 reg2 reg3 = hcat [ pprFFormat fmt, char '\t', pprReg reg1, - ptext (sLit ", "), + text ", ", pprReg reg2, - ptext (sLit ", "), + text ", ", pprReg reg3 ] diff --git a/compiler/nativeGen/PprBase.hs b/compiler/nativeGen/PprBase.hs index b2e574af4c..e5c1a28eb6 100644 --- a/compiler/nativeGen/PprBase.hs +++ b/compiler/nativeGen/PprBase.hs @@ -97,7 +97,7 @@ pprGNUSectionHeader t suffix = sdocWithDynFlags $ \dflags -> let splitSections = gopt Opt_SplitSections dflags subsection | splitSections = char '.' <> ppr suffix | otherwise = empty - in ptext (sLit ".section ") <> ptext header <> subsection + in text ".section " <> ptext header <> subsection where header = case t of Text -> sLit ".text" diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index c1c2e3cdb7..ed2ff7bf93 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -52,7 +52,6 @@ import UniqFM import UniqSupply import Bag import State -import FastString import Data.List import Data.Maybe @@ -190,17 +189,17 @@ instance Outputable instr ppr (SPILL reg slot) = hcat [ - ptext (sLit "\tSPILL"), + text "\tSPILL", char ' ', ppr reg, comma, - ptext (sLit "SLOT") <> parens (int slot)] + text "SLOT" <> parens (int slot)] ppr (RELOAD slot reg) = hcat [ - ptext (sLit "\tRELOAD"), + text "\tRELOAD", char ' ', - ptext (sLit "SLOT") <> parens (int slot), + text "SLOT" <> parens (int slot), comma, ppr reg] @@ -214,9 +213,9 @@ instance Outputable instr = ppr instr $$ (nest 8 $ vcat - [ pprRegs (ptext (sLit "# born: ")) (liveBorn live) - , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live) - , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ] + [ pprRegs (text "# born: ") (liveBorn live) + , pprRegs (text "# r_dying: ") (liveDieRead live) + , pprRegs (text "# w_dying: ") (liveDieWrite live) ] $+$ space) where pprRegs :: SDoc -> RegSet -> SDoc diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index eac88f8d0c..8c7871e059 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -106,19 +106,19 @@ pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) pprData :: CmmStatic -> SDoc pprData (CmmString str) = pprASCII str -pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes +pprData (CmmUninitialised bytes) = text ".skip " <> int bytes pprData (CmmStaticLit lit) = pprDataItem lit pprGloblDecl :: CLabel -> SDoc pprGloblDecl lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = ptext (sLit ".global ") <> ppr lbl + | otherwise = text ".global " <> ppr lbl pprTypeAndSizeDecl :: CLabel -> SDoc pprTypeAndSizeDecl lbl = sdocWithPlatform $ \platform -> if platformOS platform == OSLinux && externallyVisibleCLabel lbl - then ptext (sLit ".type ") <> ppr lbl <> ptext (sLit ", @object") + then text ".type " <> ppr lbl <> ptext (sLit ", @object") else empty pprLabel :: CLabel -> SDoc @@ -132,7 +132,7 @@ pprASCII str = vcat (map do1 str) $$ do1 0 where do1 :: Word8 -> SDoc - do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) + do1 w = text "\t.byte\t" <> int (fromIntegral w) -- ----------------------------------------------------------------------------- @@ -314,8 +314,8 @@ pprImm imm -- these should have been converted to bytes and placed -- in the data section. - ImmFloat _ -> ptext (sLit "naughty float immediate") - ImmDouble _ -> ptext (sLit "naughty double immediate") + ImmFloat _ -> text "naughty float immediate" + ImmDouble _ -> text "naughty double immediate" -- | Pretty print a section \/ segment header. @@ -344,19 +344,19 @@ pprDataItem lit where imm = litToImm lit - ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm] - ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm] + ppr_item II8 _ = [text "\t.byte\t" <> pprImm imm] + ppr_item II32 _ = [text "\t.long\t" <> pprImm imm] ppr_item FF32 (CmmFloat r _) = let bs = floatToBytes (fromRational r) - in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs + in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs ppr_item FF64 (CmmFloat r _) = let bs = doubleToBytes (fromRational r) - in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs + in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs - ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm imm] - ppr_item II64 _ = [ptext (sLit "\t.quad\t") <> pprImm imm] + ppr_item II16 _ = [text "\t.short\t" <> pprImm imm] + ppr_item II64 _ = [text "\t.quad\t" <> pprImm imm] ppr_item _ _ = panic "SPARC.Ppr.pprDataItem: no match" @@ -384,7 +384,7 @@ pprInstr (LD FF64 _ reg) pprInstr (LD format addr reg) = hcat [ - ptext (sLit "\tld"), + text "\tld", pprFormat format, char '\t', lbrack, @@ -403,7 +403,7 @@ pprInstr (ST FF64 reg _) -- so we call a special-purpose pprFormat for ST.. pprInstr (ST format reg addr) = hcat [ - ptext (sLit "\tst"), + text "\tst", pprStFormat format, char '\t', pprReg reg, @@ -415,7 +415,7 @@ pprInstr (ST format reg addr) pprInstr (ADD x cc reg1 ri reg2) | not x && not cc && riZero ri - = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ] + = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] | otherwise = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2 @@ -423,10 +423,10 @@ pprInstr (ADD x cc reg1 ri reg2) pprInstr (SUB x cc reg1 ri reg2) | not x && cc && reg2 == g0 - = hcat [ ptext (sLit "\tcmp\t"), pprReg reg1, comma, pprRI ri ] + = hcat [ text "\tcmp\t", pprReg reg1, comma, pprRI ri ] | not x && not cc && riZero ri - = hcat [ ptext (sLit "\tmov\t"), pprReg reg1, comma, pprReg reg2 ] + = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] | otherwise = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2 @@ -437,7 +437,7 @@ pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2 pprInstr (OR b reg1 ri reg2) | not b && reg1 == g0 - = let doit = hcat [ ptext (sLit "\tmov\t"), pprRI ri, comma, pprReg reg2 ] + = let doit = hcat [ text "\tmov\t", pprRI ri, comma, pprReg reg2 ] in case ri of RIReg rrr | rrr == reg2 -> empty _ -> doit @@ -454,14 +454,14 @@ pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2 pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2 pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2 -pprInstr (RDY rd) = ptext (sLit "\trd\t%y,") <> pprReg rd +pprInstr (RDY rd) = text "\trd\t%y," <> pprReg rd pprInstr (WRY reg1 reg2) - = ptext (sLit "\twr\t") + = text "\twr\t" <> pprReg reg1 <> char ',' <> pprReg reg2 <> char ',' - <> ptext (sLit "%y") + <> text "%y" pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2 pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2 @@ -470,14 +470,14 @@ pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv") b reg1 ri reg2 pprInstr (SETHI imm reg) = hcat [ - ptext (sLit "\tsethi\t"), + text "\tsethi\t", pprImm imm, comma, pprReg reg ] pprInstr NOP - = ptext (sLit "\tnop") + = text "\tnop" pprInstr (FABS format reg1 reg2) = pprFormatRegReg (sLit "fabs") format reg1 reg2 @@ -509,7 +509,7 @@ pprInstr (FSUB format reg1 reg2 reg3) pprInstr (FxTOy format1 format2 reg1 reg2) = hcat [ - ptext (sLit "\tf"), + text "\tf", ptext (case format1 of II32 -> sLit "ito" @@ -529,7 +529,7 @@ pprInstr (FxTOy format1 format2 reg1 reg2) pprInstr (BI cond b blockid) = hcat [ - ptext (sLit "\tb"), pprCond cond, + text "\tb", pprCond cond, if b then pp_comma_a else empty, char '\t', ppr (mkAsmTempLabel (getUnique blockid)) @@ -537,20 +537,20 @@ pprInstr (BI cond b blockid) pprInstr (BF cond b blockid) = hcat [ - ptext (sLit "\tfb"), pprCond cond, + text "\tfb", pprCond cond, if b then pp_comma_a else empty, char '\t', ppr (mkAsmTempLabel (getUnique blockid)) ] -pprInstr (JMP addr) = ptext (sLit "\tjmp\t") <> pprAddr addr +pprInstr (JMP addr) = text "\tjmp\t" <> pprAddr addr pprInstr (JMP_TBL op _ _) = pprInstr (JMP op) pprInstr (CALL (Left imm) n _) - = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ] + = hcat [ text "\tcall\t", pprImm imm, comma, int n ] pprInstr (CALL (Right reg) n _) - = hcat [ ptext (sLit "\tcall\t"), pprReg reg, comma, int n ] + = hcat [ text "\tcall\t", pprReg reg, comma, int n ] -- | Pretty print a RI @@ -566,8 +566,8 @@ pprFormatRegReg name format reg1 reg2 char '\t', ptext name, (case format of - FF32 -> ptext (sLit "s\t") - FF64 -> ptext (sLit "d\t") + FF32 -> text "s\t" + FF64 -> text "d\t" _ -> panic "SPARC.Ppr.pprFormatRegReg: no match"), pprReg reg1, @@ -583,8 +583,8 @@ pprFormatRegRegReg name format reg1 reg2 reg3 char '\t', ptext name, (case format of - FF32 -> ptext (sLit "s\t") - FF64 -> ptext (sLit "d\t") + FF32 -> text "s\t" + FF64 -> text "d\t" _ -> panic "SPARC.Ppr.pprFormatRegReg: no match"), pprReg reg1, comma, @@ -600,7 +600,7 @@ pprRegRIReg name b reg1 ri reg2 = hcat [ char '\t', ptext name, - if b then ptext (sLit "cc\t") else char '\t', + if b then text "cc\t" else char '\t', pprReg reg1, comma, pprRI ri, @@ -614,7 +614,7 @@ pprRIReg name b ri reg1 = hcat [ char '\t', ptext name, - if b then ptext (sLit "cc\t") else char '\t', + if b then text "cc\t" else char '\t', pprRI ri, comma, pprReg reg1 @@ -623,7 +623,7 @@ pprRIReg name b ri reg1 {- pp_ld_lbracket :: SDoc -pp_ld_lbracket = ptext (sLit "\tld\t[") +pp_ld_lbracket = text "\tld\t[" -} pp_rbracket_comma :: SDoc diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index f0ffac10d7..f2fc884d58 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -93,7 +93,7 @@ pprSizeDecl :: CLabel -> SDoc pprSizeDecl lbl = sdocWithPlatform $ \platform -> if osElfTarget (platformOS platform) - then ptext (sLit "\t.size") <+> ppr lbl <> ptext (sLit ", .-") <> ppr lbl + then text "\t.size" <+> ppr lbl <> ptext (sLit ", .-") <> ppr lbl else empty pprBasicBlock :: BlockEnv CmmStatics -> NatBasicBlock Instr -> SDoc @@ -128,21 +128,21 @@ pprData (CmmString str) = pprASCII str pprData (CmmUninitialised bytes) = sdocWithPlatform $ \platform -> - if platformOS platform == OSDarwin then ptext (sLit ".space ") <> int bytes - else ptext (sLit ".skip ") <> int bytes + if platformOS platform == OSDarwin then text ".space " <> int bytes + else text ".skip " <> int bytes pprData (CmmStaticLit lit) = pprDataItem lit pprGloblDecl :: CLabel -> SDoc pprGloblDecl lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = ptext (sLit ".globl ") <> ppr lbl + | otherwise = text ".globl " <> ppr lbl pprTypeAndSizeDecl :: CLabel -> SDoc pprTypeAndSizeDecl lbl = sdocWithPlatform $ \platform -> if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl - then ptext (sLit ".type ") <> ppr lbl <> ptext (sLit ", @object") + then text ".type " <> ppr lbl <> ptext (sLit ", @object") else empty pprLabel :: CLabel -> SDoc @@ -156,12 +156,12 @@ pprASCII str = vcat (map do1 str) $$ do1 0 where do1 :: Word8 -> SDoc - do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) + do1 w = text "\t.byte\t" <> int (fromIntegral w) pprAlign :: Int -> SDoc pprAlign bytes = sdocWithPlatform $ \platform -> - ptext (sLit ".align ") <> int (alignment platform) + text ".align " <> int (alignment platform) where alignment platform = if platformOS platform == OSDarwin then log2 bytes @@ -339,8 +339,8 @@ pprImm (ImmCLbl l) = ppr l pprImm (ImmIndex l i) = ppr l <> char '+' <> int i pprImm (ImmLit s) = s -pprImm (ImmFloat _) = ptext (sLit "naughty float immediate") -pprImm (ImmDouble _) = ptext (sLit "naughty double immediate") +pprImm (ImmFloat _) = text "naughty float immediate" +pprImm (ImmDouble _) = text "naughty double immediate" pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b pprImm (ImmConstantDiff a b) = pprImm a <> char '-' @@ -369,7 +369,7 @@ pprAddr (AddrBaseIndex base index displacement) case (base, index) of (EABaseNone, EAIndexNone) -> pp_disp (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b) - (EABaseRip, EAIndexNone) -> pp_off (ptext (sLit "%rip")) + (EABaseRip, EAIndexNone) -> pp_off (text "%rip") (EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i) (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r <> comma <> int i) @@ -386,7 +386,7 @@ pprSectionAlign (Section (OtherSection _) _) = pprSectionAlign sec@(Section seg _) = sdocWithPlatform $ \platform -> pprSectionHeader platform sec $$ - ptext (sLit ".align ") <> + text ".align " <> case platformOS platform of OSDarwin | target32Bit platform -> @@ -400,7 +400,7 @@ pprSectionAlign sec@(Section seg _) = _ | target32Bit platform -> case seg of - Text -> ptext (sLit "4,0x90") + Text -> text "4,0x90" ReadOnlyData16 -> int 16 _ -> int 4 | otherwise -> @@ -419,17 +419,17 @@ pprDataItem' dflags lit imm = litToImm lit -- These seem to be common: - ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm] - ppr_item II16 _ = [ptext (sLit "\t.word\t") <> pprImm imm] - ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm] + ppr_item II8 _ = [text "\t.byte\t" <> pprImm imm] + ppr_item II16 _ = [text "\t.word\t" <> pprImm imm] + ppr_item II32 _ = [text "\t.long\t" <> pprImm imm] ppr_item FF32 (CmmFloat r _) = let bs = floatToBytes (fromRational r) - in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs + in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs ppr_item FF64 (CmmFloat r _) = let bs = doubleToBytes (fromRational r) - in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs + in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs ppr_item II64 _ = case platformOS platform of @@ -437,17 +437,17 @@ pprDataItem' dflags lit | target32Bit platform -> case lit of CmmInt x _ -> - [ptext (sLit "\t.long\t") + [text "\t.long\t" <> int (fromIntegral (fromIntegral x :: Word32)), - ptext (sLit "\t.long\t") + text "\t.long\t" <> int (fromIntegral (fromIntegral (x `shiftR` 32) :: Word32))] _ -> panic "X86.Ppr.ppr_item: no match for II64" | otherwise -> - [ptext (sLit "\t.quad\t") <> pprImm imm] + [text "\t.quad\t" <> pprImm imm] _ | target32Bit platform -> - [ptext (sLit "\t.quad\t") <> pprImm imm] + [text "\t.quad\t" <> pprImm imm] | otherwise -> -- x86_64: binutils can't handle the R_X86_64_PC64 -- relocation type, which means we can't do @@ -462,10 +462,10 @@ pprDataItem' dflags lit case lit of -- A relative relocation: CmmLabelDiffOff _ _ _ -> - [ptext (sLit "\t.long\t") <> pprImm imm, - ptext (sLit "\t.long\t0")] + [text "\t.long\t" <> pprImm imm, + text "\t.long\t0"] _ -> - [ptext (sLit "\t.quad\t") <> pprImm imm] + [text "\t.quad\t" <> pprImm imm] ppr_item _ _ = panic "X86.Ppr.ppr_item: no match" @@ -476,11 +476,11 @@ pprInstr :: Instr -> SDoc pprInstr (COMMENT _) = empty -- nuke 'em {- -pprInstr (COMMENT s) = ptext (sLit "# ") <> ftext s +pprInstr (COMMENT s) = text "# " <> ftext s -} pprInstr (LOCATION file line col _name) - = ptext (sLit "\t.loc ") <> ppr file <+> ppr line <+> ppr col + = text "\t.loc " <> ppr file <+> ppr line <+> ppr col pprInstr (DELTA d) = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) @@ -494,17 +494,17 @@ pprInstr (LDATA _ _) {- pprInstr (SPILL reg slot) = hcat [ - ptext (sLit "\tSPILL"), + text "\tSPILL", char ' ', pprUserReg reg, comma, - ptext (sLit "SLOT") <> parens (int slot)] + text "SLOT" <> parens (int slot)] pprInstr (RELOAD slot reg) = hcat [ - ptext (sLit "\tRELOAD"), + text "\tRELOAD", char ' ', - ptext (sLit "SLOT") <> parens (int slot), + text "SLOT" <> parens (int slot), comma, pprUserReg reg] -} @@ -637,12 +637,12 @@ pprInstr (PUSH format op) = pprFormatOp (sLit "push") format op pprInstr (POP format op) = pprFormatOp (sLit "pop") format op -- both unused (SDM): --- pprInstr PUSHA = ptext (sLit "\tpushal") --- pprInstr POPA = ptext (sLit "\tpopal") +-- pprInstr PUSHA = text "\tpushal" +-- pprInstr POPA = text "\tpopal" -pprInstr NOP = ptext (sLit "\tnop") -pprInstr (CLTD II32) = ptext (sLit "\tcltd") -pprInstr (CLTD II64) = ptext (sLit "\tcqto") +pprInstr NOP = text "\tnop" +pprInstr (CLTD II32) = text "\tcltd" +pprInstr (CLTD II64) = text "\tcqto" pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op) @@ -652,14 +652,14 @@ pprInstr (JXX cond blockid) pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm) -pprInstr (JMP (OpImm imm) _) = ptext (sLit "\tjmp ") <> pprImm imm +pprInstr (JMP (OpImm imm) _) = text "\tjmp " <> pprImm imm pprInstr (JMP op _) = sdocWithPlatform $ \platform -> - ptext (sLit "\tjmp *") + text "\tjmp *" <> pprOperand (archWordFormat (target32Bit platform)) op pprInstr (JMP_TBL op _ _ _) = pprInstr (JMP op []) -pprInstr (CALL (Left imm) _) = ptext (sLit "\tcall ") <> pprImm imm +pprInstr (CALL (Left imm) _) = text "\tcall " <> pprImm imm pprInstr (CALL (Right reg) _) = sdocWithPlatform $ \platform -> - ptext (sLit "\tcall *") + text "\tcall *" <> pprReg (archWordFormat (target32Bit platform)) reg pprInstr (IDIV fmt op) = pprFormatOp (sLit "idiv") fmt op @@ -681,9 +681,9 @@ pprInstr (CVTSI2SD fmt from to) = pprFormatOpReg (sLit "cvtsi2sd") fmt from to -- FETCHGOT for PIC on ELF platforms pprInstr (FETCHGOT reg) - = vcat [ ptext (sLit "\tcall 1f"), - hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ], - hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "), + = vcat [ text "\tcall 1f", + hcat [ text "1:\tpopl\t", pprReg II32 reg ], + hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ", pprReg II32 reg ] ] @@ -692,8 +692,8 @@ pprInstr (FETCHGOT reg) -- (Terminology note: the IP is called Program Counter on PPC, -- and it's a good thing to use the same name on both platforms) pprInstr (FETCHPC reg) - = vcat [ ptext (sLit "\tcall 1f"), - hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ] + = vcat [ text "\tcall 1f", + hcat [ text "1:\tpopl\t", pprReg II32 reg ] ] @@ -912,15 +912,15 @@ pprInstr g@(GDIV _ src1 src2 dst) pprInstr GFREE - = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"), - ptext (sLit "\tffree %st(4) ;ffree %st(5)") + = vcat [ text "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)", + text "\tffree %st(4) ;ffree %st(5)" ] -- Atomics -pprInstr (LOCK i) = ptext (sLit "\tlock") $$ pprInstr i +pprInstr (LOCK i) = text "\tlock" $$ pprInstr i -pprInstr MFENCE = ptext (sLit "\tmfence") +pprInstr MFENCE = text "\tmfence" pprInstr (XADD format src dst) = pprFormatOpOp (sLit "xadd") format src dst @@ -1043,7 +1043,7 @@ pprGInstr (GDIV fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gdiv") fmt src1 s pprGInstr _ = panic "X86.Ppr.pprGInstr: no match" pprDollImm :: Imm -> SDoc -pprDollImm i = ptext (sLit "$") <> pprImm i +pprDollImm i = text "$" <> pprImm i pprOperand :: Format -> Operand -> SDoc diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index ac6571c385..7067fe0c6d 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -2272,8 +2272,8 @@ srcParseErr -> MsgDoc srcParseErr dflags buf len = if null token - then ptext (sLit "parse error (possibly incorrect indentation or mismatched brackets)") - else ptext (sLit "parse error on input") <+> quotes (text token) + then text "parse error (possibly incorrect indentation or mismatched brackets)" + else text "parse error on input" <+> quotes (text token) $$ ppWhen (not th_enabled && token == "$") -- #7396 (text "Perhaps you intended to use TemplateHaskell") $$ ppWhen (token == "<-") diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 7d903f64d8..477ef88f12 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -2949,9 +2949,9 @@ tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (unLoc $2)) [mj AnnBackquote $1,mj AnnVal $2 ,mj AnnBackquote $3] } | '.' {% parseErrorSDoc (getLoc $1) - (vcat [ptext (sLit "Illegal symbol '.' in type"), - ptext (sLit "Perhaps you intended to use RankNTypes or a similar language"), - ptext (sLit "extension to enable explicit-forall syntax: forall <tvs>. <type>")]) + (vcat [text "Illegal symbol '.' in type", + text "Perhaps you intended to use RankNTypes or a similar language", + text "extension to enable explicit-forall syntax: forall <tvs>. <type>"]) } tyvarid :: { Located RdrName } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 11ec70c27d..78ab50df9f 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -137,7 +137,7 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls ; let cxt = fromMaybe (noLoc []) mcxt ; (cls, tparams,ann) <- checkTyClHdr True tycl_hdr ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan - ; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams + ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams ; at_defs <- mapM (eitherToP . mkATDefault) at_insts ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars , tcdFDs = snd (unLoc fds) @@ -156,7 +156,7 @@ mkATDefault :: LTyFamInstDecl RdrName -- from Convert.hs mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e })) | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs } <- e - = do { tvs <- checkTyVars (ptext (sLit "default")) equalsDots tc (hsib_body pats) + = do { tvs <- checkTyVars (text "default") equalsDots tc (hsib_body pats) ; return (L loc (TyFamEqn { tfe_tycon = tc , tfe_pats = tvs , tfe_rhs = rhs })) } @@ -202,7 +202,7 @@ mkTySynonym :: SrcSpan mkTySynonym loc lhs rhs = do { (tc, tparams,ann) <- checkTyClHdr False lhs ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan - ; tyvars <- checkTyVarsP (ptext (sLit "type")) equalsDots tc tparams + ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars , tcdRhs = rhs, tcdFVs = placeHolderNames })) } @@ -659,17 +659,17 @@ checkTyVars pp_what equals_or_where tc tparms | isRdrTyVar tv = return (L l (UserTyVar (L ltv tv))) chk t@(L loc _) = Left (loc, - vcat [ ptext (sLit "Unexpected type") <+> quotes (ppr t) - , ptext (sLit "In the") <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc) - , vcat[ (ptext (sLit "A") <+> pp_what <+> ptext (sLit "declaration should have form")) + vcat [ text "Unexpected type" <+> quotes (ppr t) + , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc) + , vcat[ (text "A" <+> pp_what <+> ptext (sLit "declaration should have form")) , nest 2 (pp_what <+> ppr tc <+> hsep (map text (takeList tparms allNameStrings)) <+> equals_or_where) ] ]) whereDots, equalsDots :: SDoc -- Second argument to checkTyVars -whereDots = ptext (sLit "where ...") -equalsDots = ptext (sLit "= ...") +whereDots = text "where ..." +equalsDots = text "= ..." checkDatatypeContext :: Maybe (LHsContext RdrName) -> P () checkDatatypeContext Nothing = return () diff --git a/compiler/prelude/ForeignCall.hs b/compiler/prelude/ForeignCall.hs index a08f64b621..f23436bda6 100644 --- a/compiler/prelude/ForeignCall.hs +++ b/compiler/prelude/ForeignCall.hs @@ -67,9 +67,9 @@ data Safety {-! derive: Binary !-} instance Outputable Safety where - ppr PlaySafe = ptext (sLit "safe") - ppr PlayInterruptible = ptext (sLit "interruptible") - ppr PlayRisky = ptext (sLit "unsafe") + ppr PlaySafe = text "safe" + ppr PlayInterruptible = text "interruptible" + ppr PlayRisky = text "unsafe" playSafe :: Safety -> Bool playSafe PlaySafe = True @@ -154,11 +154,11 @@ data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptC {-! derive: Binary !-} instance Outputable CCallConv where - ppr StdCallConv = ptext (sLit "stdcall") - ppr CCallConv = ptext (sLit "ccall") - ppr CApiConv = ptext (sLit "capi") - ppr PrimCallConv = ptext (sLit "prim") - ppr JavaScriptCallConv = ptext (sLit "javascript") + ppr StdCallConv = text "stdcall" + ppr CCallConv = text "ccall" + ppr CApiConv = text "capi" + ppr PrimCallConv = text "prim" + ppr JavaScriptCallConv = text "javascript" defaultCCallConv :: CCallConv defaultCCallConv = CCallConv diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index 13e271bc66..314dd85a60 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -891,7 +891,7 @@ tagToEnumRule = do return $ mkTyApps (Var (dataConWorkId dc)) tc_args -- See Note [tagToEnum#] - _ -> WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty ) + _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty ) return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type" {- diff --git a/compiler/profiling/CostCentre.hs b/compiler/profiling/CostCentre.hs index f3bbd50e26..03cde88786 100644 --- a/compiler/profiling/CostCentre.hs +++ b/compiler/profiling/CostCentre.hs @@ -221,10 +221,10 @@ mkSingletonCCS cc = SingletonCCS cc -- expression. instance Outputable CostCentreStack where - ppr NoCCS = ptext (sLit "NO_CCS") - ppr CurrentCCS = ptext (sLit "CCCS") - ppr DontCareCCS = ptext (sLit "CCS_DONT_CARE") - ppr (SingletonCCS cc) = ppr cc <> ptext (sLit "_ccs") + ppr NoCCS = text "NO_CCS" + ppr CurrentCCS = text "CCCS" + ppr DontCareCCS = text "CCS_DONT_CARE" + ppr (SingletonCCS cc) = ppr cc <> text "_ccs" ----------------------------------------------------------------------------- @@ -270,7 +270,7 @@ ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" ppCostCentreLbl (NormalCC {cc_key = k, cc_name = n, cc_mod = m, cc_is_caf = is_caf}) = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> - case is_caf of { CafCC -> ptext (sLit "CAF"); _ -> ppr (mkUniqueGrimily k)} <> text "_cc" + case is_caf of { CafCC -> text "CAF"; _ -> ppr (mkUniqueGrimily k)} <> text "_cc" -- This is the name to go in the user-displayed string, -- recorded in the cost centre declaration diff --git a/compiler/profiling/ProfInit.hs b/compiler/profiling/ProfInit.hs index 9fddc495d4..9add61e561 100644 --- a/compiler/profiling/ProfInit.hs +++ b/compiler/profiling/ProfInit.hs @@ -37,10 +37,10 @@ profilingInitCode this_mod (local_CCs, ___extern_CCs, singleton_CCSs) ] where emitRegisterCC cc = - ptext (sLit "extern CostCentre ") <> cc_lbl <> ptext (sLit "[];") $$ - ptext (sLit "REGISTER_CC(") <> cc_lbl <> char ')' <> semi + text "extern CostCentre " <> cc_lbl <> ptext (sLit "[];") $$ + text "REGISTER_CC(" <> cc_lbl <> char ')' <> semi where cc_lbl = ppr (mkCCLabel cc) emitRegisterCCS ccs = - ptext (sLit "extern CostCentreStack ") <> ccs_lbl <> ptext (sLit "[];") $$ - ptext (sLit "REGISTER_CCS(") <> ccs_lbl <> char ')' <> semi + text "extern CostCentreStack " <> ccs_lbl <> ptext (sLit "[];") $$ + text "REGISTER_CCS(" <> ccs_lbl <> char ')' <> semi where ccs_lbl = ppr (mkCCSLabel ccs) diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index fe0909f416..33a1cb447b 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -416,8 +416,8 @@ rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname }) where localPatternSynonymErr :: SDoc localPatternSynonymErr - = hang (ptext (sLit "Illegal pattern synonym declaration for") <+> quotes (ppr rdrname)) - 2 (ptext (sLit "Pattern synonym declarations are only valid at top level")) + = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname)) + 2 (text "Pattern synonym declarations are only valid at top level") rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) @@ -604,8 +604,8 @@ makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls dupFixityDecl :: SrcSpan -> RdrName -> SDoc dupFixityDecl loc rdr_name - = vcat [ptext (sLit "Multiple fixity declarations for") <+> quotes (ppr rdr_name), - ptext (sLit "also at ") <+> ppr loc] + = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name), + text "also at " <+> ppr loc] {- ********************************************************************* @@ -688,8 +688,8 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L _ name patternSynonymErr :: SDoc patternSynonymErr - = hang (ptext (sLit "Illegal pattern synonym declaration")) - 2 (ptext (sLit "Use -XPatternSynonyms to enable this extension")) + = hang (text "Illegal pattern synonym declaration") + 2 (text "Use -XPatternSynonyms to enable this extension") {- Note [Pattern synonym builders don't yield dependencies] @@ -805,7 +805,7 @@ rnMethodBindLHS :: Bool -> Name -> RnM (LHsBindsLR Name RdrName) rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest = setSrcSpan loc $ do - do { sel_name <- wrapLocM (lookupInstDeclBndr cls (ptext (sLit "method"))) name + do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name -- We use the selector name as the binder ; let bind' = bind { fun_id = sel_name , bind_fvs = placeHolderNamesTc } @@ -816,15 +816,15 @@ rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest -- This is why we use a fold rather than map rnMethodBindLHS is_cls_decl _ (L loc bind) rest = do { addErrAt loc $ - vcat [ what <+> ptext (sLit "not allowed in") <+> decl_sort + vcat [ what <+> text "not allowed in" <+> decl_sort , nest 2 (ppr bind) ] ; return rest } where - decl_sort | is_cls_decl = ptext (sLit "class declaration:") - | otherwise = ptext (sLit "instance declaration:") + decl_sort | is_cls_decl = text "class declaration:" + | otherwise = text "instance declaration:" what = case bind of - PatBind {} -> ptext (sLit "Pattern bindings (except simple variables)") - PatSynBind {} -> ptext (sLit "Pattern synonyms") + PatBind {} -> text "Pattern bindings (except simple variables)" + PatSynBind {} -> text "Pattern synonyms" -- Associated pattern synonyms are not implemented yet _ -> pprPanic "rnMethodBind" (ppr bind) @@ -891,7 +891,7 @@ renameSig ctxt sig@(ClassOpSig is_deflt vs ty) ; return (ClassOpSig is_deflt new_v new_ty, fvs) } where (v1:_) = vs - ty_ctxt = GenericCtx (ptext (sLit "a class method signature for") + ty_ctxt = GenericCtx (text "a class method signature for" <+> quotes (ppr v1)) renameSig _ (SpecInstSig src ty) @@ -909,7 +909,7 @@ renameSig ctxt sig@(SpecSig v tys inl) ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys ; return (SpecSig new_v new_ty inl, fvs) } where - ty_ctxt = GenericCtx (ptext (sLit "a SPECIALISE signature for") + ty_ctxt = GenericCtx (text "a SPECIALISE signature for" <+> quotes (ppr v)) do_one (tys,fvs) ty = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt ty @@ -932,7 +932,7 @@ renameSig ctxt sig@(PatSynSig v ty) ; (ty', fvs) <- rnHsSigType ty_ctxt ty ; return (PatSynSig v' ty', fvs) } where - ty_ctxt = GenericCtx (ptext (sLit "a pattern synonym signature for") + ty_ctxt = GenericCtx (text "a pattern synonym signature for" <+> quotes (ppr v)) ppr_sig_bndrs :: [Located RdrName] -> SDoc @@ -1054,19 +1054,19 @@ rnMatch' ctxt rnBody match@(Match { m_fixity = mf, m_pats = pats , m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }} emptyCaseErr :: HsMatchContext Name -> SDoc -emptyCaseErr ctxt = hang (ptext (sLit "Empty list of alternatives in") <+> pp_ctxt) - 2 (ptext (sLit "Use EmptyCase to allow this")) +emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt) + 2 (text "Use EmptyCase to allow this") where pp_ctxt = case ctxt of - CaseAlt -> ptext (sLit "case expression") - LambdaExpr -> ptext (sLit "\\case expression") - _ -> ptext (sLit "(unexpected)") <+> pprMatchContextNoun ctxt + CaseAlt -> text "case expression" + LambdaExpr -> text "\\case expression" + _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt resSigErr :: Outputable body => HsMatchContext Name -> Match RdrName body -> HsType RdrName -> SDoc resSigErr ctxt match ty - = vcat [ ptext (sLit "Illegal result type signature") <+> quotes (ppr ty) + = vcat [ text "Illegal result type signature" <+> quotes (ppr ty) , nest 2 $ ptext (sLit "Result signatures are no longer supported in pattern matches") , pprMatchInCtxt ctxt match ] @@ -1126,9 +1126,9 @@ rnGRHS' ctxt rnBody (GRHS guards rhs) dupSigDeclErr :: [(Located RdrName, Sig RdrName)] -> RnM () dupSigDeclErr pairs@((L loc name, sig) : _) = addErrAt loc $ - vcat [ ptext (sLit "Duplicate") <+> what_it_is - <> ptext (sLit "s for") <+> quotes (ppr name) - , ptext (sLit "at") <+> vcat (map ppr $ sort $ map (getLoc . fst) pairs) ] + vcat [ text "Duplicate" <+> what_it_is + <> text "s for" <+> quotes (ppr name) + , text "at" <+> vcat (map ppr $ sort $ map (getLoc . fst) pairs) ] where what_it_is = hsSigDoc sig @@ -1137,32 +1137,32 @@ dupSigDeclErr [] = panic "dupSigDeclErr" misplacedSigErr :: LSig Name -> RnM () misplacedSigErr (L loc sig) = addErrAt loc $ - sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig] + sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] defaultSigErr :: Sig RdrName -> SDoc -defaultSigErr sig = vcat [ hang (ptext (sLit "Unexpected default signature:")) +defaultSigErr sig = vcat [ hang (text "Unexpected default signature:") 2 (ppr sig) - , ptext (sLit "Use DefaultSignatures to enable default signatures") ] + , text "Use DefaultSignatures to enable default signatures" ] bindsInHsBootFile :: LHsBindsLR Name RdrName -> SDoc bindsInHsBootFile mbinds - = hang (ptext (sLit "Bindings in hs-boot files are not allowed")) + = hang (text "Bindings in hs-boot files are not allowed") 2 (ppr mbinds) nonStdGuardErr :: Outputable body => [LStmtLR Name Name body] -> SDoc nonStdGuardErr guards - = hang (ptext (sLit "accepting non-standard pattern guards (use PatternGuards to suppress this message)")) + = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)") 4 (interpp'SP guards) unusedPatBindWarn :: HsBind Name -> SDoc unusedPatBindWarn bind - = hang (ptext (sLit "This pattern-binding binds no variables:")) + = hang (text "This pattern-binding binds no variables:") 2 (ppr bind) dupMinimalSigErr :: [LSig RdrName] -> RnM () dupMinimalSigErr sigs@(L loc _ : _) = addErrAt loc $ - vcat [ ptext (sLit "Multiple minimal complete definitions") - , ptext (sLit "at") <+> vcat (map ppr $ sort $ map getLoc sigs) - , ptext (sLit "Combine alternative minimal complete definitions with `|'") ] + vcat [ text "Multiple minimal complete definitions" + , text "at" <+> vcat (map ppr $ sort $ map getLoc sigs) + , text "Combine alternative minimal complete definitions with `|'" ] dupMinimalSigErr [] = panic "dupMinimalSigErr" diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 252cce6e86..0add967a35 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -373,26 +373,26 @@ lookupExactOcc_either name gres -> return (Left (sameNameErr gres)) -- Ugh! See Note [Template Haskell ambiguity] } where - exact_nm_err = hang (ptext (sLit "The exact Name") <+> quotes (ppr name) <+> ptext (sLit "is not in scope")) - 2 (vcat [ ptext (sLit "Probable cause: you used a unique Template Haskell name (NameU), ") - , ptext (sLit "perhaps via newName, but did not bind it") - , ptext (sLit "If that's it, then -ddump-splices might be useful") ]) + exact_nm_err = hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope")) + 2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), " + , text "perhaps via newName, but did not bind it" + , text "If that's it, then -ddump-splices might be useful" ]) sameNameErr :: [GlobalRdrElt] -> MsgDoc sameNameErr [] = panic "addSameNameErr: empty list" sameNameErr gres@(_ : _) - = hang (ptext (sLit "Same exact name in multiple name-spaces:")) + = hang (text "Same exact name in multiple name-spaces:") 2 (vcat (map pp_one sorted_names) $$ th_hint) where sorted_names = sortWith nameSrcLoc (map gre_name gres) pp_one name = hang (pprNameSpace (occNameSpace (getOccName name)) <+> quotes (ppr name) <> comma) - 2 (ptext (sLit "declared at:") <+> ppr (nameSrcLoc name)) + 2 (text "declared at:" <+> ppr (nameSrcLoc name)) - th_hint = vcat [ ptext (sLit "Probable cause: you bound a unique Template Haskell name (NameU),") - , ptext (sLit "perhaps via newName, in different name-spaces.") - , ptext (sLit "If that's it, then -ddump-splices might be useful") ] + th_hint = vcat [ text "Probable cause: you bound a unique Template Haskell name (NameU)," + , text "perhaps via newName, in different name-spaces." + , text "If that's it, then -ddump-splices might be useful" ] ----------------------------------------------- @@ -427,7 +427,7 @@ lookupInstDeclBndr cls what rdr Left err -> do { addErr err; return (mkUnboundNameRdr rdr) } Right nm -> return nm } where - doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls) + doc = what <+> text "of class" <+> quotes (ppr cls) ----------------------------------------------- @@ -435,7 +435,7 @@ lookupFamInstName :: Maybe Name -> Located RdrName -> RnM (Located Name) -- Used for TyData and TySynonym family instances only, -- See Note [Family instance binders] lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f RnBinds.rnMethodBind - = wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr + = wrapLocM (lookupInstDeclBndr cls (text "associated type")) tc_rdr lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* = lookupLocatedOccRn tc_rdr @@ -751,7 +751,7 @@ lookup_demoted rdr_name dflags = reportUnboundName rdr_name where - suggest_dk = ptext (sLit "A data constructor of that name is in scope; did you mean DataKinds?") + suggest_dk = text "A data constructor of that name is in scope; did you mean DataKinds?" untickedPromConstrWarn name = text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot $$ @@ -1054,19 +1054,19 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss }) where occ = greOccName gre name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name - doc = ptext (sLit "The name") <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly") + doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly") mk_msg imp_spec txt - = sep [ sep [ ptext (sLit "In the use of") + = sep [ sep [ text "In the use of" <+> pprNonVarNameSpace (occNameSpace occ) <+> quotes (ppr occ) , parens imp_msg <> colon ] , ppr txt ] where imp_mod = importSpecModule imp_spec - imp_msg = ptext (sLit "imported from") <+> ppr imp_mod <> extra + imp_msg = text "imported from" <+> ppr imp_mod <> extra extra | imp_mod == moduleName name_mod = Outputable.empty - | otherwise = ptext (sLit ", but defined in") <+> ppr name_mod + | otherwise = text ", but defined in" <+> ppr name_mod lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt lookupImpDeprec iface gre @@ -1151,7 +1151,7 @@ lookupQualifiedNameGHCi rdr_name = do { traceRn (text "lookupQualifedNameGHCi: off" <+> ppr rdr_name) ; return [] } - doc = ptext (sLit "Need to find") <+> ppr rdr_name + doc = text "Need to find" <+> ppr rdr_name {- Note [Looking up signature names] @@ -1257,7 +1257,7 @@ lookupBindGroupOcc ctxt what rdr_name lookup_cls_op cls = lookupSubBndrOcc True cls doc rdr_name where - doc = ptext (sLit "method of class") <+> quotes (ppr cls) + doc = text "method of class" <+> quotes (ppr cls) lookup_top keep_me = do { env <- getGlobalRdrEnv @@ -1276,13 +1276,13 @@ lookupBindGroupOcc ctxt what rdr_name Nothing -> bale_out_with Outputable.empty } bale_out_with msg - = return (Left (sep [ ptext (sLit "The") <+> what - <+> ptext (sLit "for") <+> quotes (ppr rdr_name) - , nest 2 $ ptext (sLit "lacks an accompanying binding")] + = return (Left (sep [ text "The" <+> what + <+> text "for" <+> quotes (ppr rdr_name) + , nest 2 $ text "lacks an accompanying binding"] $$ nest 2 msg)) - local_msg = parens $ ptext (sLit "The") <+> what <+> ptext (sLit "must be given where") - <+> quotes (ppr rdr_name) <+> ptext (sLit "is declared") + local_msg = parens $ text "The" <+> what <+> ptext (sLit "must be given where") + <+> quotes (ppr rdr_name) <+> text "is declared" --------------- @@ -1468,7 +1468,7 @@ lookupFixityRn_help' name occ ; traceRn (text "lookupFixityRn_either:" <+> msg) ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix) } - doc = ptext (sLit "Checking fixity for") <+> ppr name + doc = text "Checking fixity for" <+> ppr name --------------- lookupTyFixityRn :: Located Name -> RnM Fixity @@ -1704,7 +1704,7 @@ checkShadowedOccs (global_env,local_env) get_loc_occ ns check_shadow n | startsWithUnderscore occ = return () -- Do not report shadowing for "_x" -- See Trac #3262 - | Just n <- mb_local = complain [ptext (sLit "bound at") <+> ppr (nameSrcLoc n)] + | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)] | otherwise = do { gres' <- filterM is_shadowed_gre gres ; complain (map pprNameProvenance gres') } where @@ -1762,7 +1762,7 @@ unboundNameX where_look rdr_name extra unknownNameErr :: SDoc -> RdrName -> SDoc unknownNameErr what rdr_name - = vcat [ hang (ptext (sLit "Not in scope:")) + = vcat [ hang (text "Not in scope:") 2 (what <+> quotes (ppr rdr_name)) , extra ] where @@ -1796,7 +1796,7 @@ similarNameSuggestions where_look dflags global_env = case suggest of [] -> Outputable.empty [p] -> perhaps <+> pp_item p - ps -> sep [ perhaps <+> ptext (sLit "one of these:") + ps -> sep [ perhaps <+> text "one of these:" , nest 2 (pprWithCommas pp_item ps) ] where all_possibilities :: [(String, (RdrName, HowInScope))] @@ -1806,15 +1806,15 @@ similarNameSuggestions where_look dflags global_env ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ] suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities - perhaps = ptext (sLit "Perhaps you meant") + perhaps = text "Perhaps you meant" pp_item :: (RdrName, HowInScope) -> SDoc pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined where loc' = case loc of UnhelpfulSpan l -> parens (ppr l) - RealSrcSpan l -> parens (ptext (sLit "line") <+> int (srcSpanStartLine l)) + RealSrcSpan l -> parens (text "line" <+> int (srcSpanStartLine l)) pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+> -- Imported - parens (ptext (sLit "imported from") <+> ppr (is_mod is)) + parens (text "imported from" <+> ppr (is_mod is)) pp_ns :: RdrName -> SDoc pp_ns rdr | ns /= tried_ns = pprNameSpace ns @@ -1912,42 +1912,42 @@ importSuggestions _dflags imports rdr_name | null interesting_imports , Just name <- mod_name = hsep - [ ptext (sLit "No module named") + [ text "No module named" , quotes (ppr name) - , ptext (sLit "is imported.") + , text "is imported." ] | is_qualified , null helpful_imports , [(mod,_)] <- interesting_imports = hsep - [ ptext (sLit "Module") + [ text "Module" , quotes (ppr mod) - , ptext (sLit "does not export") + , text "does not export" , quotes (ppr occ_name) <> dot ] | is_qualified , null helpful_imports , mods <- map fst interesting_imports = hsep - [ ptext (sLit "Neither") + [ text "Neither" , quotedListWithNor (map ppr mods) - , ptext (sLit "exports") + , text "exports" , quotes (ppr occ_name) <> dot ] | [(mod,imv)] <- helpful_imports_non_hiding = fsep - [ ptext (sLit "Perhaps you want to add") + [ text "Perhaps you want to add" , quotes (ppr occ_name) - , ptext (sLit "to the import list") - , ptext (sLit "in the import of") + , text "to the import list" + , text "in the import of" , quotes (ppr mod) , parens (ppr (imv_span imv)) <> dot ] | not (null helpful_imports_non_hiding) = fsep - [ ptext (sLit "Perhaps you want to add") + [ text "Perhaps you want to add" , quotes (ppr occ_name) - , ptext (sLit "to one of these import lists:") + , text "to one of these import lists:" ] $$ nest 2 (vcat @@ -1956,19 +1956,19 @@ importSuggestions _dflags imports rdr_name ]) | [(mod,imv)] <- helpful_imports_hiding = fsep - [ ptext (sLit "Perhaps you want to remove") + [ text "Perhaps you want to remove" , quotes (ppr occ_name) - , ptext (sLit "from the explicit hiding list") - , ptext (sLit "in the import of") + , text "from the explicit hiding list" + , text "in the import of" , quotes (ppr mod) , parens (ppr (imv_span imv)) <> dot ] | not (null helpful_imports_hiding) = fsep - [ ptext (sLit "Perhaps you want to remove") + [ text "Perhaps you want to remove" , quotes (ppr occ_name) - , ptext (sLit "from the hiding clauses") - , ptext (sLit "in one of these imports:") + , text "from the hiding clauses" + , text "in one of these imports:" ] $$ nest 2 (vcat @@ -2094,7 +2094,7 @@ warnUnusedLocal :: NameEnv (FieldLabelString, Name) -> Name -> RnM () warnUnusedLocal fld_env name = when (reportable name) $ addUnusedWarning occ (nameSrcSpan name) - (ptext (sLit "Defined but not used")) + (text "Defined but not used") where occ = case lookupNameEnv fld_env name of Just (fl, _) -> mkVarOccFS fl @@ -2111,7 +2111,7 @@ warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is }) where span = importSpecLoc spec pp_mod = quotes (ppr (importSpecModule spec)) - msg = ptext (sLit "Imported from") <+> pp_mod <+> ptext (sLit "but not used") + msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used") -- | Make a map from selector names to field labels and parent tycon -- names, to be used when reporting unused record fields. @@ -2142,12 +2142,12 @@ addNameClashErrRn rdr_name gres -- If there are two or more *local* defns, we'll have reported = return () -- that already, and we don't want an error cascade | otherwise - = addErr (vcat [ptext (sLit "Ambiguous occurrence") <+> quotes (ppr rdr_name), - ptext (sLit "It could refer to") <+> vcat (msg1 : msgs)]) + = addErr (vcat [text "Ambiguous occurrence" <+> quotes (ppr rdr_name), + text "It could refer to" <+> vcat (msg1 : msgs)]) where (np1:nps) = gres msg1 = ptext (sLit "either") <+> mk_ref np1 - msgs = [ptext (sLit " or") <+> mk_ref np | np <- nps] + msgs = [text " or" <+> mk_ref np | np <- nps] mk_ref gre = sep [nom <> comma, pprNameProvenance gre] where nom = case gre_par gre of FldParent { par_lbl = Just lbl } -> text "the field" <+> quotes (ppr lbl) @@ -2155,57 +2155,57 @@ addNameClashErrRn rdr_name gres shadowedNameWarn :: OccName -> [SDoc] -> SDoc shadowedNameWarn occ shadowed_locs - = sep [ptext (sLit "This binding for") <+> quotes (ppr occ) - <+> ptext (sLit "shadows the existing binding") <> plural shadowed_locs, + = sep [text "This binding for" <+> quotes (ppr occ) + <+> text "shadows the existing binding" <> plural shadowed_locs, nest 2 (vcat shadowed_locs)] perhapsForallMsg :: SDoc perhapsForallMsg - = vcat [ ptext (sLit "Perhaps you intended to use ExplicitForAll or similar flag") - , ptext (sLit "to enable explicit-forall syntax: forall <tvs>. <type>")] + = vcat [ text "Perhaps you intended to use ExplicitForAll or similar flag" + , text "to enable explicit-forall syntax: forall <tvs>. <type>"] unknownSubordinateErr :: SDoc -> RdrName -> SDoc unknownSubordinateErr doc op -- Doc is "method of class" or -- "field of constructor" - = quotes (ppr op) <+> ptext (sLit "is not a (visible)") <+> doc + = quotes (ppr op) <+> text "is not a (visible)" <+> doc badOrigBinding :: RdrName -> SDoc badOrigBinding name - = ptext (sLit "Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) + = text "Illegal binding of built-in syntax:" <+> ppr (rdrNameOcc name) -- The rdrNameOcc is because we don't want to print Prelude.(,) dupNamesErr :: Outputable n => (n -> SrcSpan) -> [n] -> RnM () dupNamesErr get_loc names = addErrAt big_loc $ - vcat [ptext (sLit "Conflicting definitions for") <+> quotes (ppr (head names)), + vcat [text "Conflicting definitions for" <+> quotes (ppr (head names)), locations] where locs = map get_loc names big_loc = foldr1 combineSrcSpans locs - locations = ptext (sLit "Bound at:") <+> vcat (map ppr (sort locs)) + locations = text "Bound at:" <+> vcat (map ppr (sort locs)) kindSigErr :: Outputable a => a -> SDoc kindSigErr thing - = hang (ptext (sLit "Illegal kind signature for") <+> quotes (ppr thing)) - 2 (ptext (sLit "Perhaps you intended to use KindSignatures")) + = hang (text "Illegal kind signature for" <+> quotes (ppr thing)) + 2 (text "Perhaps you intended to use KindSignatures") badQualBndrErr :: RdrName -> SDoc badQualBndrErr rdr_name - = ptext (sLit "Qualified name in binding position:") <+> ppr rdr_name + = text "Qualified name in binding position:" <+> ppr rdr_name opDeclErr :: RdrName -> SDoc opDeclErr n - = hang (ptext (sLit "Illegal declaration of a type or class operator") <+> quotes (ppr n)) - 2 (ptext (sLit "Use TypeOperators to declare operators in type and declarations")) + = hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n)) + 2 (text "Use TypeOperators to declare operators in type and declarations") checkTupSize :: Int -> RnM () checkTupSize tup_size | tup_size <= mAX_TUPLE_SIZE = return () | otherwise - = addErr (sep [ptext (sLit "A") <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"), - nest 2 (parens (ptext (sLit "max size is") <+> int mAX_TUPLE_SIZE)), - nest 2 (ptext (sLit "Workaround: use nested tuples or define a data type"))]) + = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"), + nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)), + nest 2 (text "Workaround: use nested tuples or define a data type")]) {- ************************************************************************ @@ -2244,7 +2244,7 @@ withHsDocContext :: HsDocContext -> SDoc -> SDoc withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt inHsDocContext :: HsDocContext -> SDoc -inHsDocContext ctxt = ptext (sLit "In") <+> pprHsDocContext ctxt +inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt pprHsDocContext :: HsDocContext -> SDoc pprHsDocContext (GenericCtx doc) = doc @@ -2267,10 +2267,10 @@ pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr pprHsDocContext ClassInstanceCtx = text "TcSplice.reifyInstances" pprHsDocContext (ForeignDeclCtx name) - = ptext (sLit "the foreign declaration for") <+> quotes (ppr name) + = text "the foreign declaration for" <+> quotes (ppr name) pprHsDocContext (ConDeclCtx [name]) = text "the definition of data constructor" <+> quotes (ppr name) pprHsDocContext (ConDeclCtx names) = text "the definition of data constructors" <+> interpp'SP names pprHsDocContext (VectDeclCtx tycon) - = ptext (sLit "the VECTORISE pragma for type constructor") <+> quotes (ppr tycon) + = text "the VECTORISE pragma for type constructor" <+> quotes (ppr tycon) diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index c4f4bca35f..66703dfe0e 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -401,7 +401,7 @@ hsHoleExpr = HsUnboundVar (mkVarOcc "_") arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) arrowFail e - = do { addErr (vcat [ ptext (sLit "Arrow command found where an expression was expected:") + = do { addErr (vcat [ text "Arrow command found where an expression was expected:" , nest 2 (ppr e) ]) -- Return a place-holder hole, so that we can carry on -- to report other errors @@ -903,7 +903,7 @@ rnParallelStmts ctxt return_op segs thing_inside ; return ((seg':segs', thing), fvs) } cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 - dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:") + dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:" <+> quotes (ppr (head vs))) lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars) @@ -1026,7 +1026,7 @@ rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b)) fv_pat)] rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds _)))) - = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds) + = failWith (badIpBinds (text "an mdo expression") binds) rn_rec_stmt_lhs fix_env (L loc (LetStmt (L l(HsValBinds binds)))) = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds @@ -1101,7 +1101,7 @@ rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _), fv_pat) L loc (BindStmt pat' body' bind_op fail_op))] } rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _) - = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds) + = failWith (badIpBinds (text "an mdo expression") binds) rn_rec_stmt _ all_bndrs (L loc (LetStmt (L l (HsValBinds binds'))), _) = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds' @@ -1665,9 +1665,9 @@ okEmpty (PatGuard {}) = True okEmpty _ = False emptyErr :: HsStmtContext Name -> SDoc -emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension") -emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'") -emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt +emptyErr (ParStmtCtxt {}) = text "Empty statement group in parallel comprehension" +emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'" +emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt ---------------------- checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name @@ -1689,8 +1689,8 @@ checkLastStmt ctxt lstmt@(L loc stmt) LastStmt {} -> return lstmt -- "Deriving" clauses may generate a -- LastStmt directly (unlike the parser) _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } - last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt - <+> ptext (sLit "must be an expression")) + last_error = (text "The last statement in" <+> pprAStmtContext ctxt + <+> text "must be an expression") check_comp -- Expect LastStmt; this should be enforced by the parser! = case stmt of @@ -1710,17 +1710,17 @@ checkStmt ctxt (L _ stmt) IsValid -> return () NotValid extra -> addErr (msg $$ extra) } where - msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement") - , ptext (sLit "in") <+> pprAStmtContext ctxt ] + msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement") + , text "in" <+> pprAStmtContext ctxt ] pprStmtCat :: Stmt a body -> SDoc -pprStmtCat (TransStmt {}) = ptext (sLit "transform") -pprStmtCat (LastStmt {}) = ptext (sLit "return expression") -pprStmtCat (BodyStmt {}) = ptext (sLit "body") -pprStmtCat (BindStmt {}) = ptext (sLit "binding") -pprStmtCat (LetStmt {}) = ptext (sLit "let") -pprStmtCat (RecStmt {}) = ptext (sLit "rec") -pprStmtCat (ParStmt {}) = ptext (sLit "parallel") +pprStmtCat (TransStmt {}) = text "transform" +pprStmtCat (LastStmt {}) = text "return expression" +pprStmtCat (BodyStmt {}) = text "body" +pprStmtCat (BindStmt {}) = text "binding" +pprStmtCat (LetStmt {}) = text "let" +pprStmtCat (RecStmt {}) = text "rec" +pprStmtCat (ParStmt {}) = text "parallel" pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt" ------------ @@ -1767,7 +1767,7 @@ okDoStmt dflags ctxt stmt RecStmt {} | LangExt.RecursiveDo `xopt` dflags -> IsValid | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec' - | otherwise -> NotValid (ptext (sLit "Use RecursiveDo")) + | otherwise -> NotValid (text "Use RecursiveDo") BindStmt {} -> IsValid LetStmt {} -> IsValid BodyStmt {} -> IsValid @@ -1781,10 +1781,10 @@ okCompStmt dflags _ stmt BodyStmt {} -> IsValid ParStmt {} | LangExt.ParallelListComp `xopt` dflags -> IsValid - | otherwise -> NotValid (ptext (sLit "Use ParallelListComp")) + | otherwise -> NotValid (text "Use ParallelListComp") TransStmt {} | LangExt.TransformListComp `xopt` dflags -> IsValid - | otherwise -> NotValid (ptext (sLit "Use TransformListComp")) + | otherwise -> NotValid (text "Use TransformListComp") RecStmt {} -> emptyInvalid LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) ApplicativeStmt {} -> emptyInvalid @@ -1797,7 +1797,7 @@ okPArrStmt dflags _ stmt BodyStmt {} -> IsValid ParStmt {} | LangExt.ParallelListComp `xopt` dflags -> IsValid - | otherwise -> NotValid (ptext (sLit "Use ParallelListComp")) + | otherwise -> NotValid (text "Use ParallelListComp") TransStmt {} -> emptyInvalid RecStmt {} -> emptyInvalid LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) @@ -1809,21 +1809,21 @@ checkTupleSection args = do { tuple_section <- xoptM LangExt.TupleSections ; checkErr (all tupArgPresent args || tuple_section) msg } where - msg = ptext (sLit "Illegal tuple section: use TupleSections") + msg = text "Illegal tuple section: use TupleSections" --------- sectionErr :: HsExpr RdrName -> SDoc sectionErr expr - = hang (ptext (sLit "A section must be enclosed in parentheses")) - 2 (ptext (sLit "thus:") <+> (parens (ppr expr))) + = hang (text "A section must be enclosed in parentheses") + 2 (text "thus:" <+> (parens (ppr expr))) patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) -patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"), +patSynErr e = do { addErr (sep [text "Pattern syntax in expression context:", nest 4 (ppr e)] $$ text "Did you mean to enable TypeApplications?") ; return (EWildPat, emptyFVs) } badIpBinds :: Outputable a => SDoc -> a -> SDoc badIpBinds what binds - = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what) + = hang (text "Implicit-parameter bindings illegal in" <+> what) 2 (ppr binds) diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index 66af301870..7f89025872 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -205,7 +205,7 @@ rnImportDecl this_mod -- If there's an error in loadInterface, (e.g. interface -- file not found) we get lots of spurious errors from 'filterImports' let imp_mod_name = unLoc loc_imp_mod_name - doc = ppr imp_mod_name <+> ptext (sLit "is directly imported") + doc = ppr imp_mod_name <+> text "is directly imported" -- Check for self-import, which confuses the typechecker (Trac #9032) -- ghc --make rejects self-import cycles already, but batch-mode may not @@ -227,7 +227,7 @@ rnImportDecl this_mod Nothing -> True Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" || fsToUnitId pkg_fs == moduleUnitId this_mod)) - (addErr (ptext (sLit "A module cannot import itself:") <+> ppr imp_mod_name)) + (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name)) -- Check for a missing import list (Opt_WarnMissingImportList also -- checks for T(..) items but that is done in checkDodgyImport below) @@ -256,7 +256,7 @@ rnImportDecl this_mod warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags)) (warnRedundantSourceImport imp_mod_name) when (mod_safe && not (safeImportsOn dflags)) $ - addErr (ptext (sLit "safe import can't be used as Safe Haskell isn't on!") + addErr (text "safe import can't be used as Safe Haskell isn't on!" $+$ ptext (sLit $ "please enable Safe Haskell through either " ++ "Safe, Trustworthy or Unsafe")) @@ -401,7 +401,7 @@ calculateAvails dflags iface mod_safe' want_boot = warnRedundantSourceImport :: ModuleName -> SDoc warnRedundantSourceImport mod_name - = ptext (sLit "Unnecessary {-# SOURCE #-} in the import of module") + = text "Unnecessary {-# SOURCE #-} in the import of module" <+> quotes (ppr mod_name) {- @@ -1547,8 +1547,8 @@ warnUnusedImportDecls gbl_env ; let usage :: [ImportDeclUsage] usage = findImportUsage user_imports uses - ; traceRn (vcat [ ptext (sLit "Uses:") <+> ppr uses - , ptext (sLit "Import usage") <+> ppr usage]) + ; traceRn (vcat [ text "Uses:" <+> ppr uses + , text "Import usage" <+> ppr usage]) ; whenWOptM Opt_WarnUnusedImports $ mapM_ (warnUnusedImport fld_env) usage @@ -1614,7 +1614,7 @@ topSigWarnId sig_ns (ty, name) | name `elemNameSet` sig_ns = warnMissingSig msg (ty, name) | otherwise = return () where - msg = ptext (sLit "Top-level binding with no type signature:") + msg = text "Top-level binding with no type signature:" warnMissingSig :: SDoc -> (Type, Name) -> RnM () warnMissingSig msg (ty, name) = do @@ -1738,10 +1738,10 @@ warnUnusedImport fld_env (L loc decl, used, unused) | otherwise = addWarnAt loc msg2 -- Some imports are unused where msg1 = vcat [pp_herald <+> quotes pp_mod <+> pp_not_used, - nest 2 (ptext (sLit "except perhaps to import instances from") + nest 2 (text "except perhaps to import instances from" <+> quotes pp_mod), - ptext (sLit "To import instances alone, use:") - <+> ptext (sLit "import") <+> pp_mod <> parens Outputable.empty ] + text "To import instances alone, use:" + <+> text "import" <+> pp_mod <> parens Outputable.empty ] msg2 = sep [pp_herald <+> quotes sort_unused, text "from module" <+> quotes pp_mod <+> pp_not_used] pp_herald = text "The" <+> pp_qual <+> text "import of" @@ -1897,39 +1897,39 @@ not in scope without their enclosing datatype. qualImportItemErr :: RdrName -> SDoc qualImportItemErr rdr - = hang (ptext (sLit "Illegal qualified name in import item:")) + = hang (text "Illegal qualified name in import item:") 2 (ppr rdr) badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE RdrName -> SDoc badImportItemErrStd iface decl_spec ie - = sep [ptext (sLit "Module"), quotes (ppr (is_mod decl_spec)), source_import, - ptext (sLit "does not export"), quotes (ppr ie)] + = sep [text "Module", quotes (ppr (is_mod decl_spec)), source_import, + text "does not export", quotes (ppr ie)] where - source_import | mi_boot iface = ptext (sLit "(hi-boot interface)") + source_import | mi_boot iface = text "(hi-boot interface)" | otherwise = Outputable.empty badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE RdrName -> SDoc badImportItemErrDataCon dataType_occ iface decl_spec ie - = vcat [ ptext (sLit "In module") + = vcat [ text "In module" <+> quotes (ppr (is_mod decl_spec)) <+> source_import <> colon , nest 2 $ quotes datacon - <+> ptext (sLit "is a data constructor of") + <+> text "is a data constructor of" <+> quotes dataType - , ptext (sLit "To import it use") - , nest 2 $ quotes (ptext (sLit "import")) + , text "To import it use" + , nest 2 $ quotes (text "import") <+> ppr (is_mod decl_spec) <> parens_sp (dataType <> parens_sp datacon) - , ptext (sLit "or") - , nest 2 $ quotes (ptext (sLit "import")) + , text "or" + , nest 2 $ quotes (text "import") <+> ppr (is_mod decl_spec) - <> parens_sp (dataType <> ptext (sLit "(..)")) + <> parens_sp (dataType <> text "(..)") ] where datacon_occ = rdrNameOcc $ ieName ie datacon = parenSymOcc datacon_occ (ppr datacon_occ) dataType = parenSymOcc dataType_occ (ppr dataType_occ) - source_import | mi_boot iface = ptext (sLit "(hi-boot interface)") + source_import | mi_boot iface = text "(hi-boot interface)" | otherwise = Outputable.empty parens_sp d = parens (space <> d <> space) -- T( f,g ) @@ -1949,35 +1949,35 @@ badImportItemErr iface decl_spec ie avails importedFS = occNameFS . rdrNameOcc $ ieName ie illegalImportItemErr :: SDoc -illegalImportItemErr = ptext (sLit "Illegal import item") +illegalImportItemErr = text "Illegal import item" dodgyImportWarn :: RdrName -> SDoc -dodgyImportWarn item = dodgyMsg (ptext (sLit "import")) item +dodgyImportWarn item = dodgyMsg (text "import") item dodgyExportWarn :: Name -> SDoc -dodgyExportWarn item = dodgyMsg (ptext (sLit "export")) item +dodgyExportWarn item = dodgyMsg (text "export") item dodgyMsg :: (OutputableBndr n, HasOccName n) => SDoc -> n -> SDoc dodgyMsg kind tc - = sep [ ptext (sLit "The") <+> kind <+> ptext (sLit "item") + = sep [ text "The" <+> kind <+> ptext (sLit "item") <+> quotes (ppr (IEThingAll (noLoc tc))) - <+> ptext (sLit "suggests that"), - quotes (ppr tc) <+> ptext (sLit "has (in-scope) constructors or class methods,"), - ptext (sLit "but it has none") ] + <+> text "suggests that", + quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,", + text "but it has none" ] exportItemErr :: IE RdrName -> SDoc exportItemErr export_item - = sep [ ptext (sLit "The export item") <+> quotes (ppr export_item), - ptext (sLit "attempts to export constructors or class methods that are not visible here") ] + = sep [ text "The export item" <+> quotes (ppr export_item), + text "attempts to export constructors or class methods that are not visible here" ] exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName -> MsgDoc exportClashErr global_env name1 name2 ie1 ie2 - = vcat [ ptext (sLit "Conflicting exports for") <+> quotes (ppr occ) <> colon + = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon , ppr_export ie1' name1' , ppr_export ie2' name2' ] where occ = nameOccName name1 - ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> ptext (sLit "exports") <+> + ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+> quotes (ppr name)) 2 (pprNameProvenance (get_gre name))) @@ -1996,12 +1996,12 @@ addDupDeclErr [] = panic "addDupDeclErr: empty list" addDupDeclErr gres@(gre : _) = addErrAt (getSrcSpan (last sorted_names)) $ -- Report the error at the later location - vcat [ptext (sLit "Multiple declarations of") <+> + vcat [text "Multiple declarations of" <+> quotes (ppr (nameOccName name)), -- NB. print the OccName, not the Name, because the -- latter might not be in scope in the RdrEnv and so will -- be printed qualified. - ptext (sLit "Declared at:") <+> + text "Declared at:" <+> vcat (map (ppr . nameSrcLoc) sorted_names)] where name = gre_name gre @@ -2010,44 +2010,44 @@ addDupDeclErr gres@(gre : _) dupExportWarn :: OccName -> IE RdrName -> IE RdrName -> SDoc dupExportWarn occ_name ie1 ie2 = hsep [quotes (ppr occ_name), - ptext (sLit "is exported by"), quotes (ppr ie1), - ptext (sLit "and"), quotes (ppr ie2)] + text "is exported by", quotes (ppr ie1), + text "and", quotes (ppr ie2)] dupModuleExport :: ModuleName -> SDoc dupModuleExport mod - = hsep [ptext (sLit "Duplicate"), - quotes (ptext (sLit "Module") <+> ppr mod), - ptext (sLit "in export list")] + = hsep [text "Duplicate", + quotes (text "Module" <+> ppr mod), + text "in export list"] moduleNotImported :: ModuleName -> SDoc moduleNotImported mod - = ptext (sLit "The export item `module") <+> ppr mod <> - ptext (sLit "' is not imported") + = text "The export item `module" <+> ppr mod <> + text "' is not imported" nullModuleExport :: ModuleName -> SDoc nullModuleExport mod - = ptext (sLit "The export item `module") <+> ppr mod <> ptext (sLit "' exports nothing") + = text "The export item `module" <+> ppr mod <> ptext (sLit "' exports nothing") missingImportListWarn :: ModuleName -> SDoc missingImportListWarn mod - = ptext (sLit "The module") <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list") + = text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list") missingImportListItem :: IE RdrName -> SDoc missingImportListItem ie - = ptext (sLit "The import item") <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list") + = text "The import item" <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list") moduleWarn :: ModuleName -> WarningTxt -> SDoc moduleWarn mod (WarningTxt _ txt) - = sep [ ptext (sLit "Module") <+> quotes (ppr mod) <> ptext (sLit ":"), + = sep [ text "Module" <+> quotes (ppr mod) <> ptext (sLit ":"), nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ] moduleWarn mod (DeprecatedTxt _ txt) - = sep [ ptext (sLit "Module") <+> quotes (ppr mod) - <+> ptext (sLit "is deprecated:"), + = sep [ text "Module" <+> quotes (ppr mod) + <+> text "is deprecated:", nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ] packageImportErr :: SDoc packageImportErr - = ptext (sLit "Package-qualified imports are not enabled; use PackageImports") + = text "Package-qualified imports are not enabled; use PackageImports" -- This data decl will parse OK -- data T = a Int @@ -2064,4 +2064,4 @@ checkConName name = checkErr (isRdrDataCon name) (badDataCon name) badDataCon :: RdrName -> SDoc badDataCon name - = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)] + = hsep [text "Illegal data constructor name", quotes (ppr name)] diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 3b526d128a..bb82e8f639 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -57,7 +57,6 @@ import Util import ListSetOps ( removeDups ) import Outputable import SrcLoc -import FastString import Literal ( inCharRange ) import TysWiredIn ( nilDataCon ) import DataCon @@ -299,7 +298,7 @@ rnPats ctxt pats thing_inside collectPatsBinders pats' ; thing_inside pats' } } where - doc_pat = ptext (sLit "In") <+> pprMatchContext ctxt + doc_pat = text "In" <+> pprMatchContext ctxt rnPat :: HsMatchContext Name -- for error messages -> LPat RdrName @@ -550,8 +549,8 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) -- We don't want that to screw up the dot-dot fill-in stuff. doc = case mb_con of - Nothing -> ptext (sLit "constructor field name") - Just con -> ptext (sLit "field of constructor") <+> quotes (ppr con) + Nothing -> text "constructor field name" + Just con -> text "field of constructor" <+> quotes (ppr con) rn_fld :: Bool -> Maybe Name -> LHsRecField RdrName (Located arg) -> RnM (LHsRecField Name (Located arg)) @@ -671,7 +670,7 @@ rnHsRecUpdFields flds ; return (flds1, plusFVs fvss) } where - doc = ptext (sLit "constructor field name") + doc = text "constructor field name" rn_fld :: Bool -> Bool -> LHsRecUpdField RdrName -> RnM (LHsRecUpdField Name, FreeVars) rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f @@ -728,31 +727,31 @@ getFieldUpdLbls :: [LHsRecUpdField id] -> [RdrName] getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds needFlagDotDot :: HsRecFieldContext -> SDoc -needFlagDotDot ctxt = vcat [ptext (sLit "Illegal `..' in record") <+> pprRFC ctxt, - ptext (sLit "Use RecordWildCards to permit this")] +needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt, + text "Use RecordWildCards to permit this"] badDotDotCon :: Name -> SDoc badDotDotCon con - = vcat [ ptext (sLit "Illegal `..' notation for constructor") <+> quotes (ppr con) - , nest 2 (ptext (sLit "The constructor has no labelled fields")) ] + = vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con) + , nest 2 (text "The constructor has no labelled fields") ] emptyUpdateErr :: SDoc -emptyUpdateErr = ptext (sLit "Empty record update") +emptyUpdateErr = text "Empty record update" badPun :: Located RdrName -> SDoc -badPun fld = vcat [ptext (sLit "Illegal use of punning for field") <+> quotes (ppr fld), - ptext (sLit "Use NamedFieldPuns to permit this")] +badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld), + text "Use NamedFieldPuns to permit this"] dupFieldErr :: HsRecFieldContext -> [RdrName] -> SDoc dupFieldErr ctxt dups - = hsep [ptext (sLit "duplicate field name"), + = hsep [text "duplicate field name", quotes (ppr (head dups)), - ptext (sLit "in record"), pprRFC ctxt] + text "in record", pprRFC ctxt] pprRFC :: HsRecFieldContext -> SDoc -pprRFC (HsRecFieldCon {}) = ptext (sLit "construction") -pprRFC (HsRecFieldPat {}) = ptext (sLit "pattern") -pprRFC (HsRecFieldUpd {}) = ptext (sLit "update") +pprRFC (HsRecFieldCon {}) = text "construction" +pprRFC (HsRecFieldPat {}) = text "pattern" +pprRFC (HsRecFieldUpd {}) = text "update" {- ************************************************************************ @@ -803,13 +802,13 @@ rnOverLit origLit patSigErr :: Outputable a => a -> SDoc patSigErr ty - = (ptext (sLit "Illegal signature in pattern:") <+> ppr ty) - $$ nest 4 (ptext (sLit "Use ScopedTypeVariables to permit it")) + = (text "Illegal signature in pattern:" <+> ppr ty) + $$ nest 4 (text "Use ScopedTypeVariables to permit it") bogusCharError :: Char -> SDoc bogusCharError c - = ptext (sLit "character literal out of range: '\\") <> char c <> char '\'' + = text "character literal out of range: '\\" <> char c <> char '\'' badViewPat :: Pat RdrName -> SDoc -badViewPat pat = vcat [ptext (sLit "Illegal view pattern: ") <+> ppr pat, - ptext (sLit "Use ViewPatterns to enable view patterns")] +badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat, + text "Use ViewPatterns to enable view patterns"] diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index fbdfb0deab..3751dfb2d2 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -286,7 +286,7 @@ rnSrcFixityDecls bndr_set fix_decls -- this lookup will fail if the definition isn't local do names <- lookupLocalTcNames sig_ctxt what rdr_name return [ L name_loc name | (_, name) <- names ] - what = ptext (sLit "fixity signature") + what = text "fixity signature" {- ********************************************************* @@ -325,7 +325,7 @@ rnSrcWarnDecls bndr_set decls' rdr_names ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] } - what = ptext (sLit "deprecation") + what = text "deprecation" warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns) decls @@ -340,8 +340,8 @@ findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc ( dupWarnDecl :: Located RdrName -> RdrName -> SDoc -- Located RdrName -> DeprecDecl RdrName -> SDoc dupWarnDecl (L loc _) rdr_name - = vcat [ptext (sLit "Multiple warning declarations for") <+> quotes (ppr rdr_name), - ptext (sLit "also at ") <+> ppr loc] + = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), + text "also at " <+> ppr loc] {- ********************************************************* @@ -599,7 +599,7 @@ checkCanonicalInstances cls poly_ty mbinds = do = inst_decl_ctxt (ppr head_ty) inst_decl_ctxt :: SDoc -> SDoc - inst_decl_ctxt doc = hang (ptext (sLit "in the instance declaration for")) + inst_decl_ctxt doc = hang (text "in the instance declaration for") 2 (quotes doc <> text ".") @@ -879,8 +879,8 @@ rnSrcDerivDecl (DerivDecl ty overlap) standaloneDerivErr :: SDoc standaloneDerivErr - = hang (ptext (sLit "Illegal standalone deriving declaration")) - 2 (ptext (sLit "Use StandaloneDeriving to enable this extension")) + = hang (text "Illegal standalone deriving declaration") + 2 (text "Use StandaloneDeriving to enable this extension") {- ********************************************************* @@ -992,21 +992,21 @@ validRuleLhs foralls lhs badRuleVar :: FastString -> Name -> SDoc badRuleVar name var - = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon, - ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+> - ptext (sLit "does not appear on left hand side")] + = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon, + text "Forall'd variable" <+> quotes (ppr var) <+> + text "does not appear on left hand side"] badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc badRuleLhsErr name lhs bad_e - = sep [ptext (sLit "Rule") <+> pprRuleName name <> colon, + = sep [text "Rule" <+> pprRuleName name <> colon, nest 4 (vcat [err, - ptext (sLit "in left-hand side:") <+> ppr lhs])] + text "in left-hand side:" <+> ppr lhs])] $$ - ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd") + text "LHS must be of form (f e1 .. en) where f is not forall'd" where err = case bad_e of - HsUnboundVar occ -> ptext (sLit "Not in scope:") <+> ppr occ - _ -> ptext (sLit "Illegal expression:") <+> ppr bad_e + HsUnboundVar occ -> text "Not in scope:" <+> ppr occ + _ -> text "Illegal expression:" <+> ppr bad_e {- ********************************************************* @@ -1026,8 +1026,8 @@ rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _))) } rnHsVectDecl (HsVect _ _var _rhs) = failWith $ vcat - [ ptext (sLit "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma") - , ptext (sLit "must be an identifier") + [ text "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma" + , text "must be an identifier" ] rnHsVectDecl (HsNoVect s var) = do { var' <- lookupLocatedTopBndrRn var -- only applies to local (not imported) names @@ -1377,8 +1377,8 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType badGadtStupidTheta :: HsDocContext -> SDoc badGadtStupidTheta _ - = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"), - ptext (sLit "(You can put a context on each contructor, though.)")] + = vcat [text "No context is allowed on a GADT-style data declaration", + text "(You can put a context on each contructor, though.)"] rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested -- inside an *class decl* for cls @@ -1637,9 +1637,9 @@ modules), we get better error messages, too. --------------- badAssocRhs :: [Name] -> RnM () badAssocRhs ns - = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions") + = addErr (hang (text "The RHS of an associated type declaration mentions" <+> pprWithCommas (quotes . ppr) ns) - 2 (ptext (sLit "All such variables must be bound on the LHS"))) + 2 (text "All such variables must be bound on the LHS")) ----------------- rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars) @@ -1837,8 +1837,8 @@ add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds ; return (gp, Just (splice, ds)) } where - badImplicitSplice = ptext (sLit "Parse error: naked expression at top level") - $$ ptext (sLit "Perhaps you intended to use TemplateHaskell") + badImplicitSplice = text "Parse error: naked expression at top level" + $$ text "Perhaps you intended to use TemplateHaskell" -- Class declarations: pull out the fixity signatures to the top add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index 9ddf132311..9279be1570 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -534,12 +534,12 @@ rnSplicePat. spliceCtxt :: HsSplice RdrName -> SDoc spliceCtxt splice - = hang (ptext (sLit "In the") <+> what) 2 (ppr splice) + = hang (text "In the" <+> what) 2 (ppr splice) where what = case splice of - HsUntypedSplice {} -> ptext (sLit "untyped splice:") - HsTypedSplice {} -> ptext (sLit "typed splice:") - HsQuasiQuote {} -> ptext (sLit "quasi-quotation:") + HsUntypedSplice {} -> text "untyped splice:" + HsTypedSplice {} -> text "typed splice:" + HsQuasiQuote {} -> text "quasi-quotation:" -- | The splice data to be logged data SpliceInfo @@ -589,16 +589,16 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src , gen ] illegalTypedSplice :: SDoc -illegalTypedSplice = ptext (sLit "Typed splices may not appear in untyped brackets") +illegalTypedSplice = text "Typed splices may not appear in untyped brackets" illegalUntypedSplice :: SDoc -illegalUntypedSplice = ptext (sLit "Untyped splices may not appear in typed brackets") +illegalUntypedSplice = text "Untyped splices may not appear in typed brackets" -- spliceResultDoc :: OutputableBndr id => LHsExpr id -> SDoc -- spliceResultDoc expr --- = vcat [ hang (ptext (sLit "In the splice:")) +-- = vcat [ hang (text "In the splice:") -- 2 (char '$' <> pprParendExpr expr) --- , ptext (sLit "To see what the splice expanded to, use -ddump-splices") ] +-- , text "To see what the splice expanded to, use -ddump-splices" ] #endif checkThLocalName :: Name -> RnM () diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 9a3dba216e..0ddbf8ef0f 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -277,14 +277,14 @@ rnLHsInstType doc_str inst_ty , isTcOcc (rdrNameOcc (unLoc cls)) -- The guards check that the instance type looks like -- blah => C ty1 .. tyn - = do { let full_doc = doc_str <+> ptext (sLit "for") <+> quotes (ppr cls) + = do { let full_doc = doc_str <+> text "for" <+> quotes (ppr cls) ; rnHsSigType (GenericCtx full_doc) inst_ty } | otherwise -- The instance is malformed, but we'd still like -- to make progress rather than failing outright, so -- we report more errors. So we rename it anyway. = do { addErrAt (getLoc (hsSigType inst_ty)) $ - ptext (sLit "Malformed instance:") <+> ppr inst_ty + text "Malformed instance:" <+> ppr inst_ty ; rnHsSigType (GenericCtx doc_str) inst_ty } @@ -390,7 +390,7 @@ data RnTyKiWhat = RnTypeBody instance Outputable RnTyKiEnv where ppr (RTKE { rtke_level = lev, rtke_what = what , rtke_nwcs = wcs, rtke_ctxt = ctxt }) - = ptext (sLit "RTKE") + = text "RTKE" <+> braces (sep [ ppr lev, ppr what, ppr wcs , pprHsDocContext ctxt ]) @@ -499,7 +499,7 @@ rnHsTyKi env ty@(HsRecTy flds) get_fields (ConDeclCtx names) = concatMapM (lookupConstructorFields . unLoc) names get_fields _ - = do { addErr (hang (ptext (sLit "Record syntax is illegal here:")) + = do { addErr (hang (text "Record syntax is illegal here:") 2 (ppr ty)) ; return [] } @@ -553,7 +553,7 @@ rnHsTyKi env tyLit@(HsTyLit t) where negLit (HsStrTy _ _) = False negLit (HsNumTy _ i) = i < 0 - negLitErr = ptext (sLit "Illegal literal in type (type literals must not be negative):") <+> ppr tyLit + negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit rnHsTyKi env overall_ty@(HsAppsTy tys) = do { -- Step 1: Break up the HsAppsTy into symbols and non-symbol regions @@ -694,11 +694,11 @@ rnHsTyOp env overall_ty (L loc op) -------------- notAllowed :: SDoc -> SDoc notAllowed doc - = ptext (sLit "Wildcard") <+> quotes doc <+> ptext (sLit "not allowed") + = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed") checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM () checkWildCard env (Just doc) - = addErr $ vcat [doc, nest 2 (ptext (sLit "in") <+> pprHsDocContext (rtke_ctxt env))] + = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))] checkWildCard _ Nothing = return () @@ -716,10 +716,10 @@ checkAnonWildCard env wc RnConstraint -> Just constraint_msg RnTopConstraint -> Just constraint_msg - constraint_msg = hang (notAllowed (ppr wc) <+> ptext (sLit "in a constraint")) + constraint_msg = hang (notAllowed (ppr wc) <+> text "in a constraint") 2 hint_msg - hint_msg = vcat [ ptext (sLit "except as the last top-level constraint of a type signature") - , nest 2 (ptext (sLit "e.g f :: (Eq a, _) => blah")) ] + hint_msg = vcat [ text "except as the last top-level constraint of a type signature" + , nest 2 (text "e.g f :: (Eq a, _) => blah") ] checkNamedWildCard :: RnTyKiEnv -> Name -> RnM () -- Report an error if a named wildcard is illegal here @@ -735,7 +735,7 @@ checkNamedWildCard env name RnTypeBody -> Nothing -- Allowed RnTopConstraint -> Nothing -- Allowed RnConstraint -> Just constraint_msg - constraint_msg = notAllowed (ppr name) <+> ptext (sLit "in a constraint") + constraint_msg = notAllowed (ppr name) <+> text "in a constraint" checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo RdrName -> RnM () @@ -747,8 +747,8 @@ checkExtraConstraintWildCard env wc = checkWildCard env mb_bad where mb_bad | not (extraConstraintWildCardsAllowed env) - = Just (ptext (sLit "Extra-constraint wildcard") <+> quotes (ppr wc) - <+> ptext (sLit "not allowed")) + = Just (text "Extra-constraint wildcard" <+> quotes (ppr wc) + <+> text "not allowed") | otherwise = Nothing @@ -1346,25 +1346,25 @@ precParseErr op1@(n1,_) op2@(n2,_) | isUnboundName n1 || isUnboundName n2 = return () -- Avoid error cascade | otherwise - = addErr $ hang (ptext (sLit "Precedence parsing error")) - 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"), + = addErr $ hang (text "Precedence parsing error") + 4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"), ppr_opfix op2, - ptext (sLit "in the same infix expression")]) + text "in the same infix expression"]) sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM () sectionPrecErr op@(n1,_) arg_op@(n2,_) section | isUnboundName n1 || isUnboundName n2 = return () -- Avoid error cascade | otherwise - = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"), - nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"), - nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]), - nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))] + = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"), + nest 4 (sep [text "must have lower precedence than that of the operand,", + nest 2 (text "namely" <+> ppr_opfix arg_op)]), + nest 4 (text "in the section:" <+> quotes (ppr section))] ppr_opfix :: (Name, Fixity) -> SDoc ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) where - pp_op | op == negateName = ptext (sLit "prefix `-'") + pp_op | op == negateName = text "prefix `-'" | otherwise = quotes (ppr op) {- ***************************************************** @@ -1376,45 +1376,45 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) badKindBndrs :: HsDocContext -> [Located RdrName] -> SDoc badKindBndrs doc kvs = withHsDocContext doc $ - hang (ptext (sLit "Unexpected kind variable") <> plural kvs + hang (text "Unexpected kind variable" <> plural kvs <+> pprQuotedList kvs) - 2 (ptext (sLit "Perhaps you intended to use PolyKinds")) + 2 (text "Perhaps you intended to use PolyKinds") badKindSigErr :: HsDocContext -> LHsType RdrName -> TcM () badKindSigErr doc (L loc ty) = setSrcSpan loc $ addErr $ withHsDocContext doc $ - hang (ptext (sLit "Illegal kind signature:") <+> quotes (ppr ty)) - 2 (ptext (sLit "Perhaps you intended to use KindSignatures")) + hang (text "Illegal kind signature:" <+> quotes (ppr ty)) + 2 (text "Perhaps you intended to use KindSignatures") dataKindsErr :: RnTyKiEnv -> HsType RdrName -> SDoc dataKindsErr env thing - = hang (ptext (sLit "Illegal") <+> pp_what <> colon <+> quotes (ppr thing)) - 2 (ptext (sLit "Perhaps you intended to use DataKinds")) + = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing)) + 2 (text "Perhaps you intended to use DataKinds") where - pp_what | isRnKindLevel env = ptext (sLit "kind") - | otherwise = ptext (sLit "type") + pp_what | isRnKindLevel env = text "kind" + | otherwise = text "type" inTypeDoc :: HsType RdrName -> SDoc -inTypeDoc ty = ptext (sLit "In the type") <+> quotes (ppr ty) +inTypeDoc ty = text "In the type" <+> quotes (ppr ty) warnUnusedForAll :: SDoc -> LHsTyVarBndr Name -> FreeVars -> TcM () warnUnusedForAll in_doc (L loc tv) used_names = whenWOptM Opt_WarnUnusedMatches $ unless (hsTyVarName tv `elemNameSet` used_names) $ addWarnAt loc $ - vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv) + vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) , in_doc ] opTyErr :: Outputable a => RdrName -> a -> SDoc opTyErr op overall_ty - = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty)) + = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty)) 2 extra where extra | op == dot_tv_RDR = perhapsForallMsg | otherwise - = ptext (sLit "Use TypeOperators to allow operators in types") + = text "Use TypeOperators to allow operators in types" emptyNonSymsErr :: HsType RdrName -> SDoc emptyNonSymsErr overall_ty diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index 9f80a17869..13a7512ffa 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -148,30 +148,30 @@ data CoreToDo -- These are diff core-to-core passes, | CorePrep instance Outputable CoreToDo where - ppr (CoreDoSimplify _ _) = ptext (sLit "Simplifier") - ppr (CoreDoPluginPass s _) = ptext (sLit "Core plugin: ") <+> text s - ppr CoreDoFloatInwards = ptext (sLit "Float inwards") - ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f) - ppr CoreLiberateCase = ptext (sLit "Liberate case") - ppr CoreDoStaticArgs = ptext (sLit "Static argument") - ppr CoreDoCallArity = ptext (sLit "Called arity analysis") - ppr CoreDoStrictness = ptext (sLit "Demand analysis") - ppr CoreDoWorkerWrapper = ptext (sLit "Worker Wrapper binds") - ppr CoreDoSpecialising = ptext (sLit "Specialise") - ppr CoreDoSpecConstr = ptext (sLit "SpecConstr") - ppr CoreCSE = ptext (sLit "Common sub-expression") - ppr CoreDoVectorisation = ptext (sLit "Vectorisation") - ppr CoreDesugar = ptext (sLit "Desugar (before optimization)") - ppr CoreDesugarOpt = ptext (sLit "Desugar (after optimization)") - ppr CoreTidy = ptext (sLit "Tidy Core") - ppr CorePrep = ptext (sLit "CorePrep") - ppr CoreDoPrintCore = ptext (sLit "Print core") - ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check") - ppr CoreDoNothing = ptext (sLit "CoreDoNothing") - ppr (CoreDoPasses passes) = ptext (sLit "CoreDoPasses") <+> ppr passes + ppr (CoreDoSimplify _ _) = text "Simplifier" + ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s + ppr CoreDoFloatInwards = text "Float inwards" + ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f) + ppr CoreLiberateCase = text "Liberate case" + ppr CoreDoStaticArgs = text "Static argument" + ppr CoreDoCallArity = text "Called arity analysis" + ppr CoreDoStrictness = text "Demand analysis" + ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" + ppr CoreDoSpecialising = text "Specialise" + ppr CoreDoSpecConstr = text "SpecConstr" + ppr CoreCSE = text "Common sub-expression" + ppr CoreDoVectorisation = text "Vectorisation" + ppr CoreDesugar = text "Desugar (before optimization)" + ppr CoreDesugarOpt = text "Desugar (after optimization)" + ppr CoreTidy = text "Tidy Core" + ppr CorePrep = text "CorePrep" + ppr CoreDoPrintCore = text "Print core" + ppr (CoreDoRuleCheck {}) = text "Rule check" + ppr CoreDoNothing = text "CoreDoNothing" + ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes pprPassDetails :: CoreToDo -> SDoc -pprPassDetails (CoreDoSimplify n md) = vcat [ ptext (sLit "Max iterations =") <+> int n +pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n , ppr md ] pprPassDetails _ = Outputable.empty @@ -189,15 +189,15 @@ instance Outputable SimplifierMode where ppr (SimplMode { sm_phase = p, sm_names = ss , sm_rules = r, sm_inline = i , sm_eta_expand = eta, sm_case_case = cc }) - = ptext (sLit "SimplMode") <+> braces ( - sep [ ptext (sLit "Phase =") <+> ppr p <+> + = text "SimplMode" <+> braces ( + sep [ text "Phase =" <+> ppr p <+> brackets (text (concat $ intersperse "," ss)) <> comma , pp_flag i (sLit "inline") <> comma , pp_flag r (sLit "rules") <> comma , pp_flag eta (sLit "eta-expand") <> comma , pp_flag cc (sLit "case-of-case") ]) where - pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s + pp_flag f s = ppUnless f (text "no") <+> ptext s data FloatOutSwitches = FloatOutSwitches { floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if @@ -220,11 +220,11 @@ instance Outputable FloatOutSwitches where pprFloatOutSwitches :: FloatOutSwitches -> SDoc pprFloatOutSwitches sw - = ptext (sLit "FOS") <+> (braces $ + = text "FOS" <+> (braces $ sep $ punctuate comma $ - [ ptext (sLit "Lam =") <+> ppr (floatOutLambdas sw) - , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw) - , ptext (sLit "OverSatApps =") <+> ppr (floatOutOverSatApps sw) ]) + [ text "Lam =" <+> ppr (floatOutLambdas sw) + , text "Consts =" <+> ppr (floatOutConstants sw) + , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ]) -- The core-to-core pass ordering is derived from the DynFlags: runWhen :: Bool -> CoreToDo -> CoreToDo @@ -360,14 +360,14 @@ plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) plusSimplCount _ _ = panic "plusSimplCount" -- We use one or the other consistently -pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n +pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) - = vcat [ptext (sLit "Total ticks: ") <+> int tks, + = vcat [text "Total ticks: " <+> int tks, blankLine, pprTickCounts dts, if verboseSimplStats then vcat [blankLine, - ptext (sLit "Log (most recent first)"), + text "Log (most recent first)", nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] else Outputable.empty ] diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs index 7f920a230e..3c220fed74 100644 --- a/compiler/simplCore/FloatOut.hs +++ b/compiler/simplCore/FloatOut.hs @@ -27,7 +27,6 @@ import Bag import Util import Maybes import Outputable -import FastString import qualified Data.IntMap as M #include "HsVersions.h" @@ -130,9 +129,9 @@ floatOutwards float_sws dflags us pgm let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:" - (hcat [ int tlets, ptext (sLit " Lets floated to top level; "), - int ntlets, ptext (sLit " Lets floated elsewhere; from "), - int lams, ptext (sLit " Lambda groups")]); + (hcat [ int tlets, text " Lets floated to top level; ", + int ntlets, text " Lets floated elsewhere; from ", + int lams, text " Lambda groups"]); return (bagToList (unionManyBags binds_s')) } @@ -481,9 +480,9 @@ data FloatBinds = FB !(Bag FloatLet) -- Destined for top level instance Outputable FloatBinds where ppr (FB fbs defs) - = ptext (sLit "FB") <+> (braces $ vcat - [ ptext (sLit "tops =") <+> ppr fbs - , ptext (sLit "non-tops =") <+> ppr defs ]) + = text "FB" <+> (braces $ vcat + [ text "tops =" <+> ppr fbs + , text "non-tops =" <+> ppr defs ]) flattenTopFloats :: FloatBinds -> Bag CoreBind flattenTopFloats (FB tops defs) diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs index 16f819241a..d1c3ca809a 100644 --- a/compiler/simplCore/OccurAnal.hs +++ b/compiler/simplCore/OccurAnal.hs @@ -39,7 +39,6 @@ import Unique import UniqFM import Util import Outputable -import FastString import Data.List import Control.Arrow ( second ) @@ -668,12 +667,12 @@ data Details } instance Outputable Details where - ppr nd = ptext (sLit "ND") <> braces - (sep [ ptext (sLit "bndr =") <+> ppr (nd_bndr nd) - , ptext (sLit "uds =") <+> ppr (nd_uds nd) - , ptext (sLit "inl =") <+> ppr (nd_inl nd) - , ptext (sLit "weak =") <+> ppr (nd_weak nd) - , ptext (sLit "rule =") <+> ppr (nd_active_rule_fvs nd) + ppr nd = text "ND" <> braces + (sep [ text "bndr =" <+> ppr (nd_bndr nd) + , text "uds =" <+> ppr (nd_uds nd) + , text "inl =" <+> ppr (nd_inl nd) + , text "weak =" <+> ppr (nd_weak nd) + , text "rule =" <+> ppr (nd_active_rule_fvs nd) ]) makeNode :: OccEnv -> ImpRuleEdges -> VarSet -> (Var, CoreExpr) -> Node Details @@ -1484,8 +1483,8 @@ data OccEncl -- Do inline into constructor args here instance Outputable OccEncl where - ppr OccRhs = ptext (sLit "occRhs") - ppr OccVanilla = ptext (sLit "occVanilla") + ppr OccRhs = text "occRhs" + ppr OccVanilla = text "occVanilla" type OneShots = [OneShotInfo] -- [] No info diff --git a/compiler/simplCore/SAT.hs b/compiler/simplCore/SAT.hs index ac8da3f45b..38ae1444f1 100644 --- a/compiler/simplCore/SAT.hs +++ b/compiler/simplCore/SAT.hs @@ -127,10 +127,10 @@ pprSATInfo :: SATInfo -> SDoc pprSATInfo staticness = hcat $ map pprStaticness staticness pprStaticness :: Staticness App -> SDoc -pprStaticness (Static (VarApp _)) = ptext (sLit "SV") -pprStaticness (Static (TypeApp _)) = ptext (sLit "ST") -pprStaticness (Static (CoApp _)) = ptext (sLit "SC") -pprStaticness NotStatic = ptext (sLit "NS") +pprStaticness (Static (VarApp _)) = text "SV" +pprStaticness (Static (TypeApp _)) = text "ST" +pprStaticness (Static (CoApp _)) = text "SC" +pprStaticness NotStatic = text "NS" mergeSATInfo :: SATInfo -> SATInfo -> SATInfo @@ -148,9 +148,9 @@ mergeSATInfo l r = zipWith mergeSA l r | c `eqCoercion` c' = Static (CoApp c) | otherwise = NotStatic mergeSA _ _ = pprPanic "mergeSATInfo" $ - ptext (sLit "Left:") - <> pprSATInfo l <> ptext (sLit ", ") - <> ptext (sLit "Right:") + text "Left:" + <> pprSATInfo l <> text ", " + <> text "Right:" <> pprSATInfo r mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index 8670e30a29..6badbf83db 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -44,7 +44,6 @@ import DmdAnal ( dmdAnalProgram ) import CallArity ( callArityAnalProgram ) import WorkWrap ( wwTopBinds ) import Vectorise ( vectorise ) -import FastString import SrcLoc import Util import Module @@ -604,11 +603,11 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) -- about to begin, with '1' for the first | iteration_no > max_iterations -- Stop if we've run out of iterations = WARN( debugIsOn && (max_iterations > 2) - , hang (ptext (sLit "Simplifier bailing out after") <+> int max_iterations - <+> ptext (sLit "iterations") + , hang (text "Simplifier bailing out after" <+> int max_iterations + <+> text "iterations" <+> (brackets $ hsep $ punctuate comma $ map (int . simplCountN) (reverse counts_so_far))) - 2 (ptext (sLit "Size =") <+> ppr (coreBindsStats binds))) + 2 (text "Size =" <+> ppr (coreBindsStats binds))) -- Subtract 1 from iteration_no to get the -- number of iterations we actually completed @@ -720,10 +719,10 @@ dump_end_iteration dflags print_unqual iteration_no counts binds rules | otherwise = Nothing -- Show details if Opt_D_dump_simpl_iterations is on - hdr = ptext (sLit "Simplifier iteration=") <> int iteration_no - pp_counts = vcat [ ptext (sLit "---- Simplifier counts for") <+> hdr + hdr = text "Simplifier iteration=" <> int iteration_no + pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr , pprSimplCount counts - , ptext (sLit "---- End of simplifier counts for") <+> hdr ] + , text "---- End of simplifier counts for" <+> hdr ] {- ************************************************************************ @@ -929,7 +928,7 @@ shortMeOut ind_env exported_id local_id then if hasShortableIdInfo exported_id then True -- See Note [Messing up the exported Id's IdInfo] - else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id ) + else WARN( True, text "Not shorting out:" <+> ppr exported_id ) False else False diff --git a/compiler/simplCore/SimplEnv.hs b/compiler/simplCore/SimplEnv.hs index 2f2dea660f..1f77657fe1 100644 --- a/compiler/simplCore/SimplEnv.hs +++ b/compiler/simplCore/SimplEnv.hs @@ -54,7 +54,6 @@ import Coercion hiding ( substCo, substCoVar, substCoVarBndr ) import BasicTypes import MonadUtils import Outputable -import FastString import Util import Data.List @@ -126,10 +125,10 @@ type StaticEnv = SimplEnv -- Just the static part is relevant pprSimplEnv :: SimplEnv -> SDoc -- Used for debugging; selective pprSimplEnv env - = vcat [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env), - ptext (sLit "CvSubst:") <+> ppr (seCvSubst env), - ptext (sLit "IdSubst:") <+> ppr (seIdSubst env), - ptext (sLit "InScope:") <+> vcat (map ppr_one in_scope_vars) + = vcat [text "TvSubst:" <+> ppr (seTvSubst env), + text "CvSubst:" <+> ppr (seCvSubst env), + text "IdSubst:" <+> ppr (seIdSubst env), + text "InScope:" <+> vcat (map ppr_one in_scope_vars) ] where in_scope_vars = varEnvElts (getInScopeVars (seInScope env)) @@ -148,9 +147,9 @@ data SimplSR InExpr instance Outputable SimplSR where - ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e - ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v - ppr (ContEx _tv _cv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-, + ppr (DoneEx e) = text "DoneEx" <+> ppr e + ppr (DoneId v) = text "DoneId" <+> ppr v + ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-, ppr (filter_env tv), ppr (filter_env id) -}] -- where -- fvs = exprFreeVars e @@ -379,9 +378,9 @@ instance Outputable Floats where ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds) instance Outputable FloatFlag where - ppr FltLifted = ptext (sLit "FltLifted") - ppr FltOkSpec = ptext (sLit "FltOkSpec") - ppr FltCareful = ptext (sLit "FltCareful") + ppr FltLifted = text "FltLifted" + ppr FltOkSpec = text "FltOkSpec" + ppr FltCareful = text "FltCareful" andFF :: FloatFlag -> FloatFlag -> FloatFlag andFF FltCareful _ = FltCareful diff --git a/compiler/simplCore/SimplMonad.hs b/compiler/simplCore/SimplMonad.hs index f165c65db5..074d13b680 100644 --- a/compiler/simplCore/SimplMonad.hs +++ b/compiler/simplCore/SimplMonad.hs @@ -200,14 +200,14 @@ checkedTick t else let sc' = doSimplTick (st_flags st_env) t sc in sc' `seq` return ((), us, sc')) where - msg sc = vcat [ ptext (sLit "When trying") <+> ppr t - , ptext (sLit "To increase the limit, use -fsimpl-tick-factor=N (default 100)") - , ptext (sLit "If you need to do this, let GHC HQ know, and what factor you needed") + msg sc = vcat [ text "When trying" <+> ppr t + , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)" + , text "If you need to do this, let GHC HQ know, and what factor you needed" , pp_details sc , pprSimplCount sc ] pp_details sc | hasDetailedCounts sc = empty - | otherwise = ptext (sLit "To see detailed counts use -ddump-simpl-stats") + | otherwise = text "To see detailed counts use -ddump-simpl-stats" freeTick :: Tick -> SimplM () diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index 43c8cb65df..48650c3e31 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -59,7 +59,6 @@ import BasicTypes import Util import MonadUtils import Outputable -import FastString import Pair import Control.Monad ( when ) @@ -170,23 +169,23 @@ the following invariants hold -} instance Outputable DupFlag where - ppr OkToDup = ptext (sLit "ok") - ppr NoDup = ptext (sLit "nodup") - ppr Simplified = ptext (sLit "simpl") + ppr OkToDup = text "ok" + ppr NoDup = text "nodup" + ppr Simplified = text "simpl" instance Outputable SimplCont where - ppr (Stop ty interesting) = ptext (sLit "Stop") <> brackets (ppr interesting) <+> ppr ty - ppr (CastIt co cont ) = (ptext (sLit "CastIt") <+> ppr co) $$ ppr cont - ppr (TickIt t cont) = (ptext (sLit "TickIt") <+> ppr t) $$ ppr cont + ppr (Stop ty interesting) = text "Stop" <> brackets (ppr interesting) <+> ppr ty + ppr (CastIt co cont ) = (text "CastIt" <+> ppr co) $$ ppr cont + ppr (TickIt t cont) = (text "TickIt" <+> ppr t) $$ ppr cont ppr (ApplyToTy { sc_arg_ty = ty, sc_cont = cont }) - = (ptext (sLit "ApplyToTy") <+> pprParendType ty) $$ ppr cont + = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont }) - = (ptext (sLit "ApplyToVal") <+> ppr dup <+> pprParendExpr arg) + = (text "ApplyToVal" <+> ppr dup <+> pprParendExpr arg) $$ ppr cont - ppr (StrictBind b _ _ _ cont) = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont - ppr (StrictArg ai _ cont) = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont + ppr (StrictBind b _ _ _ cont) = (text "StrictBind" <+> ppr b) $$ ppr cont + ppr (StrictArg ai _ cont) = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) - = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$ + = (text "Select" <+> ppr dup <+> ppr bndr) $$ ifPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont @@ -241,9 +240,9 @@ data ArgSpec | CastBy OutCoercion -- Cast by this; c.f. CastIt instance Outputable ArgSpec where - ppr (ValArg e) = ptext (sLit "ValArg") <+> ppr e - ppr (TyArg { as_arg_ty = ty }) = ptext (sLit "TyArg") <+> ppr ty - ppr (CastBy c) = ptext (sLit "CastBy") <+> ppr c + ppr (ValArg e) = text "ValArg" <+> ppr e + ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty + ppr (CastBy c) = text "CastBy" <+> ppr c addValArgTo :: ArgInfo -> OutExpr -> ArgInfo addValArgTo ai arg = ai { ai_args = ValArg arg : ai_args ai @@ -1377,7 +1376,7 @@ tryEtaExpandRhs env bndr rhs ; (new_arity, new_rhs) <- try_expand dflags ; WARN( new_arity < old_id_arity, - (ptext (sLit "Arity decrease:") <+> (ppr bndr <+> ppr old_id_arity + (text "Arity decrease:" <+> (ppr bndr <+> ppr old_id_arity <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) ) -- Note [Arity decrease] in Simplify return (new_arity, new_rhs) } diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index 2b2b4358bc..6880330c4e 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -2307,7 +2307,7 @@ missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExp -- it "sees" that the entire branch of an outer case is -- inaccessible. So we simply put an error case here instead. missingAlt env case_bndr _ cont - = WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr ) + = WARN( True, text "missingAlt" <+> ppr case_bndr ) return (env, mkImpossibleExpr (contResultType cont)) {- @@ -2487,7 +2487,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') = do unf = mkInlineUnfolding Nothing rhs rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs' - LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt") + LitAlt {} -> WARN( True, text "mkDupableAlt" <+> ppr case_bndr <+> ppr con ) case_bndr -- The case binder is alive but trivial, so why has diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs index 531b13166c..fbae186915 100644 --- a/compiler/specialise/Rules.hs +++ b/compiler/specialise/Rules.hs @@ -421,10 +421,10 @@ findBest target (rule1,ans1) ((rule2,ans2):prs) | otherwise = doubleQuotes (ftext (ru_name rule)) in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" (vcat [if opt_PprStyle_Debug then - ptext (sLit "Expression to match:") <+> ppr fn <+> sep (map ppr args) + text "Expression to match:" <+> ppr fn <+> sep (map ppr args) else empty, - ptext (sLit "Rule 1:") <+> pp_rule rule1, - ptext (sLit "Rule 2:") <+> pp_rule rule2]) $ + text "Rule 1:" <+> pp_rule rule1, + text "Rule 2:" <+> pp_rule rule2]) $ findBest target (rule1,ans1) prs | otherwise = findBest target (rule1,ans1) prs where @@ -575,11 +575,11 @@ matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es = env unbound var = pprPanic "Template variable unbound in rewrite rule" $ - vcat [ ptext (sLit "Variable:") <+> ppr var - , ptext (sLit "Rule") <+> pprRuleName rule_name - , ptext (sLit "Rule bndrs:") <+> ppr tmpl_vars - , ptext (sLit "LHS args:") <+> ppr tmpl_es - , ptext (sLit "Actual args:") <+> ppr target_es ] + vcat [ text "Variable:" <+> ppr var + , text "Rule" <+> pprRuleName rule_name + , text "Rule bndrs:" <+> ppr tmpl_vars + , text "LHS args:" <+> ppr tmpl_es + , text "Actual args:" <+> ppr target_es ] {- Note [Unbound template type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1185,9 +1185,9 @@ ruleAppCheck_help env fn args rules rule_herald rule <> colon <+> rule_info dflags rule rule_herald (BuiltinRule { ru_name = name }) - = ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name) + = text "Builtin rule" <+> doubleQuotes (ftext name) rule_herald (Rule { ru_name = name }) - = ptext (sLit "Rule") <+> doubleQuotes (ftext name) + = text "Rule" <+> doubleQuotes (ftext name) rule_info dflags rule | Just _ <- matchRule dflags (emptyInScopeSet, rc_id_unf env) diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs index db56d6995b..10d5614127 100644 --- a/compiler/specialise/SpecConstr.hs +++ b/compiler/specialise/SpecConstr.hs @@ -812,7 +812,7 @@ data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors instance Outputable Value where ppr (ConVal con args) = ppr con <+> interpp'SP args - ppr LambdaVal = ptext (sLit "<Lambda>") + ppr LambdaVal = text "<Lambda>" --------------------- initScEnv :: DynFlags -> Module -> UniqFM SpecConstrAnnotation -> ScEnv @@ -1058,8 +1058,8 @@ data Call = Call Id [CoreArg] ValueEnv instance Outputable ScUsage where ppr (SCU { scu_calls = calls, scu_occs = occs }) - = ptext (sLit "SCU") <+> braces (sep [ ptext (sLit "calls =") <+> ppr calls - , ptext (sLit "occs =") <+> ppr occs ]) + = text "SCU" <+> braces (sep [ ptext (sLit "calls =") <+> ppr calls + , text "occs =" <+> ppr occs ]) instance Outputable Call where ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args) @@ -1071,8 +1071,8 @@ combineCalls :: CallEnv -> CallEnv -> CallEnv combineCalls = plusVarEnv_C (++) where -- plus cs ds | length res > 1 --- = pprTrace "combineCalls" (vcat [ ptext (sLit "cs:") <+> ppr cs --- , ptext (sLit "ds:") <+> ppr ds]) +-- = pprTrace "combineCalls" (vcat [ text "cs:" <+> ppr cs +-- , text "ds:" <+> ppr ds]) -- res -- | otherwise = res -- where @@ -1118,9 +1118,9 @@ A pattern binds b, x::a, y::b, z::b->a, but not 'a'! -} instance Outputable ArgOcc where - ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs - ppr UnkOcc = ptext (sLit "unk-occ") - ppr NoOcc = ptext (sLit "no-occ") + ppr (ScrutOcc xs) = text "scrut-occ" <> ppr xs + ppr UnkOcc = text "unk-occ" + ppr NoOcc = text "no-occ" evalScrutOcc :: ArgOcc evalScrutOcc = ScrutOcc emptyUFM @@ -1545,14 +1545,14 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs return (nullUsage, spec_info) else return (nullUsage, spec_info) where - msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn) - , nest 2 (ptext (sLit "has") <+> - speakNOf spec_count' (ptext (sLit "call pattern")) <> comma <+> - ptext (sLit "but the limit is") <+> int max) ] - , ptext (sLit "Use -fspec-constr-count=n to set the bound") + msg = vcat [ sep [ text "Function" <+> quotes (ppr fn) + , nest 2 (text "has" <+> + speakNOf spec_count' (text "call pattern") <> comma <+> + text "but the limit is" <+> int max) ] + , text "Use -fspec-constr-count=n to set the bound" , extra ] - extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations") - | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs]) + extra | not opt_PprStyle_Debug = text "Use -dppr-debug to see specialisations" + | otherwise = text "Specialisations:" <+> ppr (pats ++ [p | OS p _ _ _ <- specs]) _normal_case -> do { diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs index 1507510b0d..d86a95a6b3 100644 --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -722,11 +722,11 @@ specImport dflags this_mod top_env done callers rb fn calls_for_fn ; return (rules2 ++ rules1, final_binds) } | warnMissingSpecs dflags callers - = do { warnMsg (vcat [ hang (ptext (sLit "Could not specialise imported function") <+> quotes (ppr fn)) - 2 (vcat [ ptext (sLit "when specialising") <+> quotes (ppr caller) + = do { warnMsg (vcat [ hang (text "Could not specialise imported function" <+> quotes (ppr fn)) + 2 (vcat [ text "when specialising" <+> quotes (ppr caller) | caller <- callers]) - , ifPprDebug (ptext (sLit "calls:") <+> vcat (map (pprCallInfo fn) calls_for_fn)) - , ptext (sLit "Probable fix: add INLINEABLE pragma on") <+> quotes (ppr fn) ]) + , ifPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) + , text "Probable fix: add INLINEABLE pragma on" <+> quotes (ppr fn) ]) ; return ([], []) } | otherwise @@ -1169,7 +1169,7 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs | otherwise -- No calls or RHS doesn't fit our preconceptions = WARN( not (exprIsTrivial rhs) && notNull calls_for_me, - ptext (sLit "Missed specialisation opportunity for") + text "Missed specialisation opportunity for" <+> ppr fn $$ _trace_doc ) -- Note [Specialisation shape] -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $ @@ -1273,9 +1273,9 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs -- forall b, d1',d2'. f t1 b t3 d1' d2' = f1 b herald = case mb_mod of Nothing -- Specialising local fn - -> ptext (sLit "SPEC") + -> text "SPEC" Just this_mod -- Specialising imoprted fn - -> ptext (sLit "SPEC/") <> ppr this_mod + -> text "SPEC/" <> ppr this_mod rule_name = mkFastString $ showSDocForUser dflags neverQualify $ herald <+> ppr fn <+> hsep (map ppr_call_key_ty call_ts) @@ -1694,9 +1694,9 @@ data UsageDetails instance Outputable UsageDetails where ppr (MkUD { ud_binds = dbs, ud_calls = calls }) - = ptext (sLit "MkUD") <+> braces (sep (punctuate comma - [ptext (sLit "binds") <+> equals <+> ppr dbs, - ptext (sLit "calls") <+> equals <+> ppr calls])) + = text "MkUD" <+> braces (sep (punctuate comma + [text "binds" <+> equals <+> ppr dbs, + text "calls" <+> equals <+> ppr calls])) -- | A 'DictBind' is a binding along with a cached set containing its free -- variables (both type variables and dictionaries) @@ -1724,7 +1724,7 @@ data CallInfoSet = CIS Id (Map CallKey ([DictExpr], VarSet)) type CallInfo = (CallKey, ([DictExpr], VarSet)) instance Outputable CallInfoSet where - ppr (CIS fn map) = hang (ptext (sLit "CIS") <+> ppr fn) + ppr (CIS fn map) = hang (text "CIS" <+> ppr fn) 2 (ppr map) pprCallInfo :: Id -> CallInfo -> SDoc diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs index 7cef1b93d3..07db9bf775 100644 --- a/compiler/stgSyn/CoreToStg.hs +++ b/compiler/stgSyn/CoreToStg.hs @@ -310,8 +310,8 @@ coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs) id_arity = idArity bndr mk_arity_msg stg_arity = vcat [ppr bndr, - ptext (sLit "Id arity:") <+> ppr id_arity, - ptext (sLit "STG arity:") <+> ppr stg_arity] + text "Id arity:" <+> ppr id_arity, + text "STG arity:" <+> ppr stg_arity] mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr @@ -663,7 +663,7 @@ coreToStgArgs (arg : args) = do -- Non-type argument -- we complain. -- We also want to check if a pointer is cast to a non-ptr etc - WARN( bad_args, ptext (sLit "Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg ) + WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg ) return (stg_arg : stg_args, fvs, ticks ++ aticks) diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs index 7aa07b25d3..1499ae216c 100644 --- a/compiler/stgSyn/StgLint.hs +++ b/compiler/stgSyn/StgLint.hs @@ -25,7 +25,6 @@ import TyCon import Util import SrcLoc import Outputable -import FastString import Control.Monad import Data.Function @@ -64,12 +63,12 @@ lintStgBindings whodunnit binds case (initL (lint_binds binds)) of Nothing -> binds Just msg -> pprPanic "" (vcat [ - ptext (sLit "*** Stg Lint ErrMsgs: in") <+> - text whodunnit <+> ptext (sLit "***"), + text "*** Stg Lint ErrMsgs: in" <+> + text whodunnit <+> text "***", msg, - ptext (sLit "*** Offending Program ***"), + text "*** Offending Program ***", pprStgBindings binds, - ptext (sLit "*** End of Offense ***")]) + text "*** End of Offense ***"]) where lint_binds :: [StgBinding] -> LintM () @@ -168,7 +167,7 @@ lintStgExpr (StgOpApp _ args res_ty) = runMaybeT $ do return res_ty lintStgExpr (StgLam bndrs _) = do - addErrL (ptext (sLit "Unexpected StgLam") <+> ppr bndrs) + addErrL (text "Unexpected StgLam" <+> ppr bndrs) return Nothing lintStgExpr (StgLet binds body) = do @@ -282,12 +281,12 @@ data LintLocInfo dumpLoc :: LintLocInfo -> (SrcSpan, SDoc) dumpLoc (RhsOf v) = - (srcLocSpan (getSrcLoc v), ptext (sLit " [RHS of ") <> pp_binders [v] <> char ']' ) + (srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' ) dumpLoc (LambdaBodyOf bs) = - (srcLocSpan (getSrcLoc (head bs)), ptext (sLit " [in body of lambda with binders ") <> pp_binders bs <> char ']' ) + (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' ) dumpLoc (BodyOfLetRec bs) = - (srcLocSpan (getSrcLoc (head bs)), ptext (sLit " [in body of letrec with binders ") <> pp_binders bs <> char ']' ) + (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' ) pp_binders :: [Id] -> SDoc @@ -451,7 +450,7 @@ stgEqType orig_ty1 orig_ty2 checkInScope :: Id -> LintM () checkInScope id = LintM $ \loc scope errs -> if isLocalId id && not (id `elemVarSet` scope) then - ((), addErr errs (hsep [ppr id, ptext (sLit "is out of scope")]) loc) + ((), addErr errs (hsep [ppr id, text "is out of scope"]) loc) else ((), errs) @@ -468,21 +467,21 @@ _mkCaseAltMsg _alts mkDefltMsg :: Id -> TyCon -> MsgDoc mkDefltMsg bndr tc - = ($$) (ptext (sLit "Binder of a case expression doesn't match type of scrutinee:")) + = ($$) (text "Binder of a case expression doesn't match type of scrutinee:") (ppr bndr $$ ppr (idType bndr) $$ ppr tc) mkFunAppMsg :: Type -> [Type] -> StgExpr -> MsgDoc mkFunAppMsg fun_ty arg_tys expr = vcat [text "In a function application, function type doesn't match arg types:", - hang (ptext (sLit "Function type:")) 4 (ppr fun_ty), - hang (ptext (sLit "Arg types:")) 4 (vcat (map (ppr) arg_tys)), - hang (ptext (sLit "Expression:")) 4 (ppr expr)] + hang (text "Function type:") 4 (ppr fun_ty), + hang (text "Arg types:") 4 (vcat (map (ppr) arg_tys)), + hang (text "Expression:") 4 (ppr expr)] mkRhsConMsg :: Type -> [Type] -> MsgDoc mkRhsConMsg fun_ty arg_tys = vcat [text "In a RHS constructor application, con type doesn't match arg types:", - hang (ptext (sLit "Constructor type:")) 4 (ppr fun_ty), - hang (ptext (sLit "Arg types:")) 4 (vcat (map (ppr) arg_tys))] + hang (text "Constructor type:") 4 (ppr fun_ty), + hang (text "Arg types:") 4 (vcat (map (ppr) arg_tys))] mkAltMsg1 :: Type -> MsgDoc mkAltMsg1 ty @@ -515,15 +514,15 @@ mkAlgAltMsg4 ty arg _mkRhsMsg :: Id -> Type -> MsgDoc _mkRhsMsg binder ty - = vcat [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"), + = vcat [hsep [text "The type of this binder doesn't match the type of its RHS:", ppr binder], - hsep [ptext (sLit "Binder's type:"), ppr (idType binder)], - hsep [ptext (sLit "Rhs type:"), ppr ty] + hsep [text "Binder's type:", ppr (idType binder)], + hsep [text "Rhs type:", ppr ty] ] mkUnLiftedTyMsg :: Id -> StgRhs -> SDoc mkUnLiftedTyMsg binder rhs - = (ptext (sLit "Let(rec) binder") <+> quotes (ppr binder) <+> - ptext (sLit "has unlifted type") <+> quotes (ppr (idType binder))) + = (text "Let(rec) binder" <+> quotes (ppr binder) <+> + text "has unlifted type" <+> quotes (ppr (idType binder))) $$ - (ptext (sLit "RHS:") <+> ppr rhs) + (text "RHS:" <+> ppr rhs) diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs index f0eb2d5e93..204e843567 100644 --- a/compiler/stgSyn/StgSyn.hs +++ b/compiler/stgSyn/StgSyn.hs @@ -480,7 +480,7 @@ combineStgBinderInfo _ _ = NoStgBinderInfo -------------- pp_binder_info :: StgBinderInfo -> SDoc pp_binder_info NoStgBinderInfo = empty -pp_binder_info SatCallsOnly = ptext (sLit "sat-only") +pp_binder_info SatCallsOnly = text "sat-only" {- ************************************************************************ @@ -609,7 +609,7 @@ nonEmptySRT NoSRT = False nonEmptySRT (SRTEntries vs) = not (isEmptyVarSet vs) pprSRT :: SRT -> SDoc -pprSRT (NoSRT) = ptext (sLit "_no_srt_") +pprSRT (NoSRT) = text "_no_srt_" pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids {- @@ -631,8 +631,8 @@ pprGenStgBinding (StgNonRec bndr rhs) 4 (ppr rhs <> semi) pprGenStgBinding (StgRec pairs) - = vcat $ ifPprDebug (ptext $ sLit "{- StgRec (begin) -}") : - map (ppr_bind) pairs ++ [ifPprDebug $ ptext $ sLit "{- StgRec (end) -}"] + = vcat $ ifPprDebug (text "{- StgRec (begin) -}") : + map (ppr_bind) pairs ++ [ifPprDebug (text "{- StgRec (end) -}")] where ppr_bind (bndr, expr) = hang (hsep [pprBndr LetBind bndr, equals]) @@ -680,7 +680,7 @@ pprStgExpr (StgOpApp op args _) pprStgExpr (StgLam bndrs body) = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) bndrs) - <+> ptext (sLit "->"), + <+> text "->", pprStgExpr body ] where ppr_list = brackets . fsep . punctuate comma @@ -696,13 +696,13 @@ pprStgExpr (StgLam bndrs body) pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs)) expr@(StgLet _ _)) = ($$) - (hang (hcat [ptext (sLit "let { "), ppr bndr, ptext (sLit " = "), + (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "), ppr cc, pp_binder_info bi, - ptext (sLit " ["), ifPprDebug (interppSP free_vars), ptext (sLit "] \\"), - ppr upd_flag, ptext (sLit " ["), + text " [", ifPprDebug (interppSP free_vars), ptext (sLit "] \\"), + ppr upd_flag, text " [", interppSP args, char ']']) - 8 (sep [hsep [ppr rhs, ptext (sLit "} in")]])) + 8 (sep [hsep [ppr rhs, text "} in"]])) (ppr expr) -} @@ -710,23 +710,23 @@ pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag a pprStgExpr (StgLet bind expr@(StgLet _ _)) = ($$) - (sep [hang (ptext (sLit "let {")) - 2 (hsep [pprGenStgBinding bind, ptext (sLit "} in")])]) + (sep [hang (text "let {") + 2 (hsep [pprGenStgBinding bind, text "} in"])]) (ppr expr) -- general case pprStgExpr (StgLet bind expr) - = sep [hang (ptext (sLit "let {")) 2 (pprGenStgBinding bind), - hang (ptext (sLit "} in ")) 2 (ppr expr)] + = sep [hang (text "let {") 2 (pprGenStgBinding bind), + hang (text "} in ") 2 (ppr expr)] pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr) - = sep [hang (ptext (sLit "let-no-escape {")) + = sep [hang (text "let-no-escape {") 2 (pprGenStgBinding bind), - hang (ptext (sLit "} in ") <> + hang (text "} in " <> ifPprDebug ( nest 4 ( hcat [ptext (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole), - ptext (sLit "]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss), + text "]; rhs lvs: [", interppSP (uniqSetToList lvs_rhss), char ']']))) 2 (ppr expr)] @@ -738,15 +738,15 @@ pprStgExpr (StgTick tickish expr) pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts) - = sep [sep [ptext (sLit "case"), + = sep [sep [text "case", nest 4 (hsep [pprStgExpr expr, ifPprDebug (dcolon <+> ppr alt_type)]), - ptext (sLit "of"), pprBndr CaseBind bndr, char '{'], + text "of", pprBndr CaseBind bndr, char '{'], ifPprDebug ( nest 4 ( hcat [ptext (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole), - ptext (sLit "]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss), - ptext (sLit "]; "), + text "]; rhs lvs: [", interppSP (uniqSetToList lvs_rhss), + text "]; ", pprMaybeSRT srt])), nest 2 (vcat (map pprStgAlt alts)), char '}'] @@ -754,7 +754,7 @@ pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts) pprStgAlt :: (OutputableBndr bndr, Outputable occ, Ord occ) => GenStgAlt bndr occ -> SDoc pprStgAlt (con, params, _use_mask, expr) - = hang (hsep [ppr con, sep (map (pprBndr CaseBind) params), ptext (sLit "->")]) + = hang (hsep [ppr con, sep (map (pprBndr CaseBind) params), text "->"]) 4 (ppr expr <> semi) pprStgOp :: StgOp -> SDoc @@ -763,10 +763,10 @@ pprStgOp (StgPrimCallOp op)= ppr op pprStgOp (StgFCallOp op _) = ppr op instance Outputable AltType where - ppr PolyAlt = ptext (sLit "Polymorphic") - ppr (UbxTupAlt n) = ptext (sLit "UbxTup") <+> ppr n - ppr (AlgAlt tc) = ptext (sLit "Alg") <+> ppr tc - ppr (PrimAlt tc) = ptext (sLit "Prim") <+> ppr tc + ppr PolyAlt = text "Polymorphic" + ppr (UbxTupAlt n) = text "UbxTup" <+> ppr n + ppr (AlgAlt tc) = text "Alg" <+> ppr tc + ppr (PrimAlt tc) = text "Prim" <+> ppr tc pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc pprStgLVs lvs @@ -784,7 +784,7 @@ pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp fun = hcat [ ppr cc, pp_binder_info bi, brackets (ifPprDebug (ppr free_var)), - ptext (sLit " \\"), ppr upd_flag, pprMaybeSRT srt, ptext (sLit " [] "), ppr func ] + text " \\", ppr upd_flag, pprMaybeSRT srt, ptext (sLit " [] "), ppr func ] -- general case pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body) @@ -797,8 +797,8 @@ pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body) pprStgRhs (StgRhsCon cc con args) = hcat [ ppr cc, - space, ppr con, ptext (sLit "! "), brackets (interppSP args)] + space, ppr con, text "! ", brackets (interppSP args)] pprMaybeSRT :: SRT -> SDoc pprMaybeSRT (NoSRT) = empty -pprMaybeSRT srt = ptext (sLit "srt:") <> pprSRT srt +pprMaybeSRT srt = text "srt:" <> pprSRT srt diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs index 3d6c376448..0a731e9481 100644 --- a/compiler/stranal/DmdAnal.hs +++ b/compiler/stranal/DmdAnal.hs @@ -20,7 +20,6 @@ import CoreSyn import Outputable import VarEnv import BasicTypes -import FastString import Data.List import DataCon import Id @@ -1007,9 +1006,9 @@ type SigEnv = VarEnv (StrictSig, TopLevelFlag) instance Outputable AnalEnv where ppr (AE { ae_sigs = env, ae_virgin = virgin }) - = ptext (sLit "AE") <+> braces (vcat - [ ptext (sLit "ae_virgin =") <+> ppr virgin - , ptext (sLit "ae_sigs =") <+> ppr env ]) + = text "AE" <+> braces (vcat + [ text "ae_virgin =" <+> ppr virgin + , text "ae_sigs =" <+> ppr env ]) emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv emptyAnalEnv dflags fam_envs diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs index 1ee3e1b6ac..b9aca82f6a 100644 --- a/compiler/stranal/WwLib.hs +++ b/compiler/stranal/WwLib.hs @@ -750,7 +750,7 @@ mk_absent_let dflags arg | arg_ty `eqType` voidPrimTy = Just (Let (NonRec arg (Var voidPrimId))) | otherwise - = WARN( True, ptext (sLit "No absent value for") <+> ppr arg_ty ) + = WARN( True, text "No absent value for" <+> ppr arg_ty ) Nothing where arg_ty = idType arg diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs index c5eec49140..e4b2cc3517 100644 --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -28,7 +28,6 @@ import DynFlags import Module import Outputable import UniqFM -import FastString import Util import RdrName import DataCon ( dataConName ) @@ -187,7 +186,7 @@ getFamInsts hpt_fam_insts mod ; return (expectJust "checkFamInstConsistency" $ lookupModuleEnv (eps_mod_fam_inst_env eps) mod) } where - doc = ppr mod <+> ptext (sLit "is a family-instance module") + doc = ppr mod <+> text "is a family-instance module" {- ************************************************************************ diff --git a/compiler/typecheck/FunDeps.hs b/compiler/typecheck/FunDeps.hs index b4edd37c3e..edf178182b 100644 --- a/compiler/typecheck/FunDeps.hs +++ b/compiler/typecheck/FunDeps.hs @@ -32,7 +32,6 @@ import Outputable import ErrUtils( Validity(..), allValid ) import SrcLoc import Util -import FastString import Pair ( Pair(..) ) import Data.List ( nubBy ) @@ -185,8 +184,8 @@ improveFromAnother _ _ _ = [] pprEquation :: FunDepEqn a -> SDoc pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs }) - = vcat [ptext (sLit "forall") <+> braces (pprWithCommas ppr qtvs), - nest 2 (vcat [ ppr t1 <+> ptext (sLit "~") <+> ppr t2 + = vcat [text "forall" <+> braces (pprWithCommas ppr qtvs), + nest 2 (vcat [ ppr t1 <+> text "~" <+> ppr t2 | Pair t1 t2 <- pairs])] improveFromInstEnv :: InstEnvs @@ -389,26 +388,26 @@ checkInstCoverage be_liberal clas theta inst_taus -- , text "theta" <+> ppr theta -- , text "oclose" <+> ppr (oclose theta (closeOverKinds ls_tvs)) -- , text "rs_tvs" <+> ppr rs_tvs - sep [ ptext (sLit "The") - <+> ppWhen be_liberal (ptext (sLit "liberal")) - <+> ptext (sLit "coverage condition fails in class") + sep [ text "The" + <+> ppWhen be_liberal (text "liberal") + <+> text "coverage condition fails in class" <+> quotes (ppr clas) - , nest 2 $ ptext (sLit "for functional dependency:") + , nest 2 $ text "for functional dependency:" <+> quotes (pprFunDep fd) ] - , sep [ ptext (sLit "Reason: lhs type")<>plural ls <+> pprQuotedList ls + , sep [ text "Reason: lhs type"<>plural ls <+> pprQuotedList ls , nest 2 $ (if isSingleton ls - then ptext (sLit "does not") - else ptext (sLit "do not jointly")) - <+> ptext (sLit "determine rhs type")<>plural rs + then text "does not" + else text "do not jointly") + <+> text "determine rhs type"<>plural rs <+> pprQuotedList rs ] - , ptext (sLit "Un-determined variable") <> plural undet_list <> colon + , text "Un-determined variable" <> plural undet_list <> colon <+> pprWithCommas ppr undet_list , ppWhen (isEmptyVarSet $ pSnd undetermined_tvs) $ - ptext (sLit "(Use -fprint-explicit-kinds to see the kind variables in the types)") + text "(Use -fprint-explicit-kinds to see the kind variables in the types)" , ppWhen (not be_liberal && and (isEmptyVarSet <$> liberal_undet_tvs)) $ - ptext (sLit "Using UndecidableInstances might help") ] + text "Using UndecidableInstances might help" ] {- Note [Closing over kinds in coverage] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 8878ba6b46..43f7f1eba7 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -467,9 +467,9 @@ syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv -> TcRn (TidyEnv, SDoc) syntaxNameCtxt name orig ty tidy_env = do { inst_loc <- getCtLocM orig (Just TypeLevel) - ; let msg = vcat [ ptext (sLit "When checking that") <+> quotes (ppr name) - <+> ptext (sLit "(needed by a syntactic construct)") - , nest 2 (ptext (sLit "has the required type:") + ; let msg = vcat [ text "When checking that" <+> quotes (ppr name) + <+> text "(needed by a syntactic construct)" + , nest 2 (text "has the required type:" <+> ppr (tidyType tidy_env ty)) , nest 2 (pprCtLoc inst_loc) ] ; return (tidy_env, msg) } @@ -524,7 +524,7 @@ newClsInst overlap_mode dfun_name tvs theta clas tys instOrphWarn :: ClsInst -> SDoc instOrphWarn inst - = hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst) + = hang (text "Orphan instance:") 2 (pprInstanceHdr inst) $$ text "To avoid this" $$ nest 4 (vcat possibilities) where @@ -656,12 +656,12 @@ traceDFuns ispecs funDepErr :: ClsInst -> [ClsInst] -> TcRn () funDepErr ispec ispecs - = addClsInstsErr (ptext (sLit "Functional dependencies conflict between instance declarations:")) + = addClsInstsErr (text "Functional dependencies conflict between instance declarations:") (ispec : ispecs) dupInstErr :: ClsInst -> ClsInst -> TcRn () dupInstErr ispec dup_ispec - = addClsInstsErr (ptext (sLit "Duplicate instance declarations:")) + = addClsInstsErr (text "Duplicate instance declarations:") [ispec, dup_ispec] addClsInstsErr :: SDoc -> [ClsInst] -> TcRn () diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs index 688a1e9370..b80d5bd236 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -23,8 +23,6 @@ import TcRnMonad import SrcLoc import Outputable -import FastString - #ifndef GHCI tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation] @@ -32,8 +30,8 @@ tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation] tcAnnotations [] = return [] tcAnnotations anns@(L loc _ : _) = do { setSrcSpan loc $ addWarnTc $ - (ptext (sLit "Ignoring ANN annotation") <> plural anns <> comma - <+> ptext (sLit "because this is a stage-1 compiler or doesn't support GHCi")) + (text "Ignoring ANN annotation" <> plural anns <> comma + <+> text "because this is a stage-1 compiler or doesn't support GHCi") ; return [] } #else @@ -55,8 +53,8 @@ tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do when (safeLanguageOn dflags) $ failWithTc safeHsErr runAnnotation target expr where - safeHsErr = vcat [ ptext (sLit "Annotations are not compatible with Safe Haskell.") - , ptext (sLit "See https://ghc.haskell.org/trac/ghc/ticket/10826") ] + safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell." + , text "See https://ghc.haskell.org/trac/ghc/ticket/10826" ] annProvenanceToTarget :: Module -> AnnProvenance Name -> AnnTarget Name annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name @@ -66,4 +64,4 @@ annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod annCtxt :: OutputableBndr id => AnnDecl id -> SDoc annCtxt ann - = hang (ptext (sLit "In the annotation:")) 2 (ppr ann) + = hang (text "In the annotation:") 2 (ppr ann) diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index 7f00d437fd..a781c0397e 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -31,7 +31,6 @@ import TysPrim import BasicTypes( Arity ) import SrcLoc import Outputable -import FastString import Util import Control.Monad @@ -168,7 +167,7 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if ; let r_ty = mkTyVarTy r_tv ; let if_ty = mkFunTys [pred_ty, r_ty, r_ty] r_ty ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty)) - (ptext (sLit "Predicate type of `ifThenElse' depends on result type")) + (text "Predicate type of `ifThenElse' depends on result type") ; fun' <- tcSyntaxOp IfOrigin fun if_ty ; pred' <- tcMonoExpr pred pred_ty ; b1' <- tcCmd env b1 res_ty @@ -314,8 +313,8 @@ tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) -- This is where expressions that aren't commands get rejected tc_cmd _ cmd _ - = failWithTc (vcat [ptext (sLit "The expression"), nest 2 (ppr cmd), - ptext (sLit "was found where an arrow command was expected")]) + = failWithTc (vcat [text "The expression", nest 2 (ppr cmd), + text "was found where an arrow command was expected"]) matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType) @@ -420,4 +419,4 @@ arrowTyConKind = mkFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind -} cmdCtxt :: HsCmd Name -> SDoc -cmdCtxt cmd = ptext (sLit "In the command:") <+> ppr cmd +cmdCtxt cmd = text "In the command:" <+> ppr cmd diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index b306f93727..dacdafdff1 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -55,7 +55,6 @@ import Maybes import Util import BasicTypes import Outputable -import FastString import Type(mkStrLitTy, tidyOpenType) import PrelNames( mkUnboundName, gHC_PRIM, ipClassName ) import TcValidity (checkValidType) @@ -216,7 +215,7 @@ tcHsBootSigs binds sigs tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) badBootDeclErr :: MsgDoc -badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file") +badBootDeclErr = text "Illegal declarations in an hs-boot file" ------------------------ tcLocalBinds :: HsLocalBinds Name -> TcM thing @@ -439,10 +438,10 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a recursivePatSynErr binds = failWithTc $ - hang (ptext (sLit "Recursive pattern synonym definition with following bindings:")) + hang (text "Recursive pattern synonym definition with following bindings:") 2 (vcat $ map pprLBind . bagToList $ binds) where - pprLoc loc = parens (ptext (sLit "defined at") <+> ppr loc) + pprLoc loc = parens (text "defined at" <+> ppr loc) pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+> pprLoc loc @@ -908,22 +907,22 @@ mk_impedence_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig }) inf_ty sig_ty tidy_env = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty - ; let msg = vcat [ ptext (sLit "When checking that the inferred type") + ; let msg = vcat [ text "When checking that the inferred type" , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty - , ptext (sLit "is as general as its") <+> what <+> ptext (sLit "signature") + , text "is as general as its" <+> what <+> text "signature" , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ] ; return (tidy_env2, msg) } where what = case mb_sig of - Nothing -> ptext (sLit "inferred") - Just sig | isPartialSig sig -> ptext (sLit "(partial)") + Nothing -> text "inferred" + Just sig | isPartialSig sig -> text "(partial)" | otherwise -> empty mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) mk_inf_msg poly_name poly_ty tidy_env = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty - ; let msg = vcat [ ptext (sLit "When checking the inferred type") + ; let msg = vcat [ text "When checking the inferred type" , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ] ; return (tidy_env1, msg) } @@ -935,7 +934,7 @@ localSigWarn id mb_sig | not (isSigmaTy (idType id)) = return () | otherwise = warnMissingSig msg id where - msg = ptext (sLit "Polymorphic local binding with no type signature:") + msg = text "Polymorphic local binding with no type signature:" warnMissingSig :: SDoc -> Id -> TcM () warnMissingSig msg id @@ -1167,7 +1166,7 @@ mkPragEnv sigs binds -- add arity only for real INLINE pragmas, not INLINABLE = case lookupNameEnv ar_env n of Just ar -> inl_prag { inl_sat = Just ar } - Nothing -> WARN( True, ptext (sLit "mkPragEnv no arity") <+> ppr n ) + Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n ) -- There really should be a binding for every INLINE pragma inl_prag | otherwise @@ -1204,7 +1203,7 @@ tcSpecPrags poly_id prag_sigs is_bad_sig s = not (isSpecLSig s || isInlineLSig s) warn_discarded_sigs - = addWarnTc (hang (ptext (sLit "Discarding unexpected pragmas for") <+> ppr poly_id) + = addWarnTc (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) 2 (vcat (map (ppr . getLoc) bad_sigs))) -------------- @@ -1219,7 +1218,7 @@ tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl) -- what the user wrote (Trac #8537) = addErrCtxt (spec_ctxt prag) $ do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) - (ptext (sLit "SPECIALISE pragma for non-overloaded function") + (text "SPECIALISE pragma for non-overloaded function" <+> quotes (ppr fun_name)) -- Note [SPECIALISE pragmas] ; spec_prags <- mapM tc_one hs_tys @@ -1228,7 +1227,7 @@ tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl) where name = idName poly_id poly_ty = idType poly_id - spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) + spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag) tc_one hs_ty = do { spec_ty <- tcHsSigType (FunSigCtxt name False) hs_ty @@ -1289,11 +1288,11 @@ tcImpSpec (name, prag) impSpecErr :: Name -> SDoc impSpecErr name - = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name)) - 2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma") + = hang (text "You cannot SPECIALISE" <+> quotes (ppr name)) + 2 (vcat [ text "because its definition has no INLINE/INLINABLE pragma" , parens $ sep - [ ptext (sLit "or its defining module") <+> quotes (ppr mod) - , ptext (sLit "was compiled without -O")]]) + [ text "or its defining module" <+> quotes (ppr mod) + , text "was compiled without -O"]]) where mod = nameModule name @@ -1316,7 +1315,7 @@ tcVectDecls decls where reportVectDups (first:_second:_more) = addErrAt (getSrcSpan first) $ - ptext (sLit "Duplicate vectorisation declarations for") <+> ppr first + text "Duplicate vectorisation declarations for" <+> ppr first reportVectDups _ = return () -------------- @@ -1396,10 +1395,10 @@ tcVect (HsVectInstOut _) = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'" vectCtxt :: Outputable thing => thing -> SDoc -vectCtxt thing = ptext (sLit "When checking the vectorisation declaration for") <+> ppr thing +vectCtxt thing = text "When checking the vectorisation declaration for" <+> ppr thing scalarTyConMustBeNullary :: MsgDoc -scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary") +scalarTyConMustBeNullary = text "VECTORISE SCALAR type constructor must be nullary" {- Note [SPECIALISE pragmas] @@ -1927,9 +1926,9 @@ data GeneralisationPlan -- no "polymorphic Id" and "monmomorphic Id"; there is just the one instance Outputable GeneralisationPlan where - ppr NoGen = ptext (sLit "NoGen") - ppr (InferGen b) = ptext (sLit "InferGen") <+> ppr b - ppr (CheckGen _ s) = ptext (sLit "CheckGen") <+> ppr s + ppr NoGen = text "NoGen" + ppr (InferGen b) = text "InferGen" <+> ppr b + ppr (CheckGen _ s) = text "CheckGen" <+> ppr s decideGeneralisationPlan :: DynFlags -> TcTypeEnv -> [Name] @@ -2089,17 +2088,17 @@ unliftedMustBeBang binds polyBindErr :: [LHsBind Name] -> SDoc polyBindErr binds - = hang (ptext (sLit "You can't mix polymorphic and unlifted bindings")) + = hang (text "You can't mix polymorphic and unlifted bindings") 2 (vcat [vcat (map ppr binds), - ptext (sLit "Probable fix: add a type signature")]) + text "Probable fix: add a type signature"]) strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc strictBindErr flavour any_unlifted_bndr binds - = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) + = hang (text flavour <+> msg <+> text "aren't allowed:") 2 (vcat (map ppr binds)) where - msg | any_unlifted_bndr = ptext (sLit "bindings for unlifted types") - | otherwise = ptext (sLit "bang-pattern or unboxed-tuple bindings") + msg | any_unlifted_bndr = text "bindings for unlifted types" + | otherwise = text "bang-pattern or unboxed-tuple bindings" {- Note [Compiling GHC.Prim] @@ -2129,7 +2128,7 @@ the common case.) -} -- and on RHS, when pat is TcId and grhss is still Name patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Name body -> SDoc patMonoBindsCtxt pat grhss - = hang (ptext (sLit "In a pattern binding:")) 2 (pprPatBind pat grhss) + = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) typeSigCtxt :: UserTypeCtxt -> TcIdSigBndr -> SDoc typeSigCtxt ctxt (PartialSig { sig_hs_ty = hs_ty }) diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index 031c5dbb3f..d0c36261e3 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -37,7 +37,6 @@ import MonadUtils import Control.Monad import Data.List ( zip4, foldl' ) import BasicTypes -import FastString import Data.Bifunctor ( bimap ) @@ -1693,8 +1692,8 @@ instance Functor StopOrContinue where fmap _ (Stop ev s) = Stop ev s instance Outputable a => Outputable (StopOrContinue a) where - ppr (Stop ev s) = ptext (sLit "Stop") <> parens s <+> ppr ev - ppr (ContinueWith w) = ptext (sLit "ContinueWith") <+> ppr w + ppr (Stop ev s) = text "Stop" <> parens s <+> ppr ev + ppr (ContinueWith w) = text "ContinueWith" <+> ppr w continueWith :: a -> TcS (StopOrContinue a) continueWith = return . ContinueWith diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index 6411fa980d..4fe42b08a3 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -211,7 +211,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn ; spec_prags <- discardConstraints $ tcSpecPrags global_dm_id prags ; warnTc (not (null spec_prags)) - (ptext (sLit "Ignoring SPECIALISE pragmas on default method") + (text "Ignoring SPECIALISE pragmas on default method" <+> quotes (ppr sel_name)) ; let hs_ty = lookupHsSig hs_sig_fn sel_name @@ -386,8 +386,8 @@ This makes the error messages right. -} tcMkDeclCtxt :: TyClDecl Name -> SDoc -tcMkDeclCtxt decl = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl, - ptext (sLit "declaration for"), quotes (ppr (tcdName decl))] +tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl, + text "declaration for", quotes (ppr (tcdName decl))] tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a tcAddDeclCtxt decl thing_inside @@ -395,44 +395,44 @@ tcAddDeclCtxt decl thing_inside badMethodErr :: Outputable a => a -> Name -> SDoc badMethodErr clas op - = hsep [ptext (sLit "Class"), quotes (ppr clas), - ptext (sLit "does not have a method"), quotes (ppr op)] + = hsep [text "Class", quotes (ppr clas), + text "does not have a method", quotes (ppr op)] badGenericMethod :: Outputable a => a -> Name -> SDoc badGenericMethod clas op - = hsep [ptext (sLit "Class"), quotes (ppr clas), - ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)] + = hsep [text "Class", quotes (ppr clas), + text "has a generic-default signature without a binding", quotes (ppr op)] {- badGenericInstanceType :: LHsBinds Name -> SDoc badGenericInstanceType binds - = vcat [ptext (sLit "Illegal type pattern in the generic bindings"), + = vcat [text "Illegal type pattern in the generic bindings", nest 2 (ppr binds)] missingGenericInstances :: [Name] -> SDoc missingGenericInstances missing - = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing + = text "Missing type patterns for" <+> pprQuotedList missing dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc dupGenericInsts tc_inst_infos - = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"), + = vcat [text "More than one type pattern for a single generic type constructor:", nest 2 (vcat (map ppr_inst_ty tc_inst_infos)), - ptext (sLit "All the type patterns for a generic type constructor must be identical") + text "All the type patterns for a generic type constructor must be identical" ] where ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst) -} badDmPrag :: Id -> Sig Name -> TcM () badDmPrag sel_id prag - = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method") + = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method") <+> quotes (ppr sel_id) - <+> ptext (sLit "lacks an accompanying binding")) + <+> text "lacks an accompanying binding") warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc warningMinimalDefIncomplete mindef - = vcat [ ptext (sLit "The MINIMAL pragma does not require:") + = vcat [ text "The MINIMAL pragma does not require:" , nest 2 (pprBooleanFormulaNice mindef) - , ptext (sLit "but there is no default implementation.") ] + , text "but there is no default implementation." ] tcATDefault :: Bool -- If a warning should be emitted when a default instance -- definition is not provided by the user @@ -493,6 +493,6 @@ warnMissingAT name = do { warn <- woptM Opt_WarnMissingMethods ; traceTc "warn" (ppr name <+> ppr warn) ; warnTc warn -- Warn only if -Wmissing-methods - (ptext (sLit "No explicit") <+> text "associated type" - <+> ptext (sLit "or default declaration for ") + (text "No explicit" <+> text "associated type" + <+> text "or default declaration for " <+> quotes (ppr name)) } diff --git a/compiler/typecheck/TcDefaults.hs b/compiler/typecheck/TcDefaults.hs index fb43bebf45..f45dd633bf 100644 --- a/compiler/typecheck/TcDefaults.hs +++ b/compiler/typecheck/TcDefaults.hs @@ -81,21 +81,21 @@ check_instance ty cls ; return (isJust mb_res) } defaultDeclCtxt :: SDoc -defaultDeclCtxt = ptext (sLit "When checking the types in a default declaration") +defaultDeclCtxt = text "When checking the types in a default declaration" dupDefaultDeclErr :: [Located (DefaultDecl Name)] -> SDoc dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things) - = hang (ptext (sLit "Multiple default declarations")) + = hang (text "Multiple default declarations") 2 (vcat (map pp dup_things)) where - pp (L locn (DefaultDecl _)) = ptext (sLit "here was another default declaration") <+> ppr locn + pp (L locn (DefaultDecl _)) = text "here was another default declaration" <+> ppr locn dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" polyDefErr :: LHsType Name -> SDoc polyDefErr ty - = hang (ptext (sLit "Illegal polymorphic type in default declaration") <> colon) 2 (ppr ty) + = hang (text "Illegal polymorphic type in default declaration" <> colon) 2 (ppr ty) badDefaultTy :: Type -> [Class] -> SDoc badDefaultTy ty deflt_clss - = hang (ptext (sLit "The default type") <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of")) - 2 (foldr1 (\a b -> a <+> ptext (sLit "or") <+> b) (map (quotes. ppr) deflt_clss)) + = hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of")) + 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss)) diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index c790956fa8..385aa5dc41 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -174,8 +174,8 @@ instance Outputable theta => Outputable (DerivSpec theta) where ppr = pprDerivSpec instance Outputable EarlyDerivSpec where - ppr (InferTheta spec) = ppr spec <+> ptext (sLit "(Infer)") - ppr (GivenTheta spec) = ppr spec <+> ptext (sLit "(Given)") + ppr (InferTheta spec) = ppr spec <+> text "(Infer)" + ppr (GivenTheta spec) = ppr spec <+> text "(Given)" instance Outputable PredOrigin where ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging @@ -368,7 +368,7 @@ tcDeriving deriv_infos deriv_decls -> Bag FamInst -- ^ Rep type family instances -> SDoc ddump_deriving inst_infos extra_binds repFamInsts - = hang (ptext (sLit "Derived instances:")) + = hang (text "Derived instances:") 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos)) $$ ppr extra_binds) $$ hangP "GHC.Generics representation types:" @@ -379,7 +379,7 @@ tcDeriving deriv_infos deriv_decls -- Prints the representable type family instance pprRepTy :: FamInst -> SDoc pprRepTy fi@(FamInst { fi_tys = lhs }) - = ptext (sLit "type") <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+> + = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+> equals <+> ppr rhs where rhs = famInstRHS fi @@ -495,8 +495,8 @@ makeDerivSpecs is_boot deriv_infos deriv_decls where add_deriv_err eqn = setSrcSpan (earlyDSLoc eqn) $ - addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file")) - 2 (ptext (sLit "Use an instance declaration instead"))) + addErr (hang (text "Deriving not permitted in hs-boot file") + 2 (text "Use an instance declaration instead")) ------------------------------------------------------------------ -- | Process a `deriving` clause @@ -554,15 +554,15 @@ deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode)) _ -> -- Complain about functions, primitive types, etc, failWithTc $ derivingThingErr False cls cls_tys inst_ty $ - ptext (sLit "The last argument of the instance must be a data or newtype application") + text "The last argument of the instance must be a data or newtype application" } warnUselessTypeable :: TcM () warnUselessTypeable = do { warn <- woptM Opt_WarnDerivingTypeable ; when warn $ addWarnTc - $ ptext (sLit "Deriving") <+> quotes (ppr typeableClassName) <+> - ptext (sLit "has no effect: all types now auto-derive Typeable") } + $ text "Deriving" <+> quotes (ppr typeableClassName) <+> + text "has no effect: all types now auto-derive Typeable" } ------------------------------------------------------------------ deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance @@ -752,7 +752,7 @@ mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta ; let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tycon tc_args -- If it's still a data family, the lookup failed; i.e no instance exists ; when (isDataFamilyTyCon rep_tc) - (bale_out (ptext (sLit "No family instance for") <+> quotes (pprTypeApp tycon tc_args))) + (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args))) -- For standalone deriving (mtheta /= Nothing), -- check that all the data constructors are in scope. @@ -1118,12 +1118,12 @@ checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args classArgsErr :: Class -> [Type] -> SDoc -classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class") +classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class" nonStdErr :: Class -> SDoc nonStdErr cls = quotes (ppr cls) - <+> ptext (sLit "is not a standard derivable class (Eq, Show, etc.)") + <+> text "is not a standard derivable class (Eq, Show, etc.)" sideConditions :: DerivContext -> Class -> Maybe Condition -- Side conditions for classes that GHC knows about, @@ -1174,10 +1174,10 @@ canDeriveAnyClass :: DynFlags -> TyCon -> Class -> Maybe SDoc -- Precondition: the class is not one of the standard ones canDeriveAnyClass dflags _tycon clas | not (xopt LangExt.DeriveAnyClass dflags) - = Just (ptext (sLit "Try enabling DeriveAnyClass")) + = Just (text "Try enabling DeriveAnyClass") | not (any (target_kind `tcEqKind`) [ liftedTypeKind, typeToTypeKind ]) - = Just (ptext (sLit "The last argument of class") <+> quotes (ppr clas) - <+> ptext (sLit "does not have kind * or (* -> *)")) + = Just (text "The last argument of class" <+> quotes (ppr clas) + <+> text "does not have kind * or (* -> *)") | otherwise = Nothing -- OK! where @@ -1202,7 +1202,7 @@ orCond c1 c2 tc = case (c1 tc, c2 tc) of (IsValid, _) -> IsValid -- c1 succeeds (_, IsValid) -> IsValid -- c21 succeeds - (NotValid x, NotValid y) -> NotValid (x $$ ptext (sLit " or") $$ y) + (NotValid x, NotValid y) -> NotValid (x $$ text " or" $$ y) -- Both fail andCond :: Condition -> Condition -> Condition @@ -1223,22 +1223,22 @@ cond_stdOK Nothing permissive (_, rep_tc, _) | not (null con_whys) = NotValid (vcat con_whys $$ suggestion) | otherwise = IsValid where - suggestion = ptext (sLit "Possible fix: use a standalone deriving declaration instead") + suggestion = text "Possible fix: use a standalone deriving declaration instead" data_cons = tyConDataCons rep_tc con_whys = getInvalids (map check_con data_cons) check_con :: DataCon -> Validity check_con con | not (isVanillaDataCon con) - = NotValid (badCon con (ptext (sLit "has existentials or constraints in its type"))) + = NotValid (badCon con (text "has existentials or constraints in its type")) | not (permissive || all isTauTy (dataConOrigArgTys con)) - = NotValid (badCon con (ptext (sLit "has a higher-rank type"))) + = NotValid (badCon con (text "has a higher-rank type")) | otherwise = IsValid no_cons_why :: TyCon -> SDoc no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "must have at least one data constructor") + text "must have at least one data constructor" cond_RepresentableOk :: Condition cond_RepresentableOk (_, tc, tc_args) = canDoGenerics tc tc_args @@ -1256,8 +1256,8 @@ cond_args :: Class -> Condition cond_args cls (_, tc, _) = case bad_args of [] -> IsValid - (ty:_) -> NotValid (hang (ptext (sLit "Don't know how to derive") <+> quotes (ppr cls)) - 2 (ptext (sLit "for type") <+> quotes (ppr ty))) + (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls)) + 2 (text "for type" <+> quotes (ppr ty))) where bad_args = [ arg_ty | con <- tyConDataCons tc , arg_ty <- dataConOrigArgTys con @@ -1282,8 +1282,8 @@ cond_isEnumeration (_, rep_tc, _) | otherwise = NotValid why where why = sep [ quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "must be an enumeration type") - , ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ] + text "must be an enumeration type" + , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ] -- See Note [Enumeration types] in TyCon cond_isProduct :: Condition @@ -1292,7 +1292,7 @@ cond_isProduct (_, rep_tc, _) | otherwise = NotValid why where why = quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "must have precisely one constructor") + text "must have precisely one constructor" cond_functorOK :: Bool -> Bool -> Condition -- OK for Functor/Foldable/Traversable class @@ -1303,12 +1303,12 @@ cond_functorOK :: Bool -> Bool -> Condition -- (e) no "stupid context" on data type cond_functorOK allowFunctions allowExQuantifiedLastTyVar (_, rep_tc, _) | null tc_tvs - = NotValid (ptext (sLit "Data type") <+> quotes (ppr rep_tc) - <+> ptext (sLit "must have some type parameters")) + = NotValid (text "Data type" <+> quotes (ppr rep_tc) + <+> text "must have some type parameters") | not (null bad_stupid_theta) - = NotValid (ptext (sLit "Data type") <+> quotes (ppr rep_tc) - <+> ptext (sLit "must not have a class context:") <+> pprTheta bad_stupid_theta) + = NotValid (text "Data type" <+> quotes (ppr rep_tc) + <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta) | otherwise = allValid (map check_con data_cons) @@ -1343,18 +1343,18 @@ cond_functorOK allowFunctions allowExQuantifiedLastTyVar (_, rep_tc, _) , ft_bad_app = NotValid (badCon con wrong_arg) , ft_forall = \_ x -> x } - existential = ptext (sLit "must be truly polymorphic in the last argument of the data type") - covariant = ptext (sLit "must not use the type variable in a function argument") - functions = ptext (sLit "must not contain function types") - wrong_arg = ptext (sLit "must use the type variable only as the last argument of a data type") + existential = text "must be truly polymorphic in the last argument of the data type" + covariant = text "must not use the type variable in a function argument" + functions = text "must not contain function types" + wrong_arg = text "must use the type variable only as the last argument of a data type" checkFlag :: LangExt.Extension -> Condition checkFlag flag (dflags, _, _) | xopt flag dflags = IsValid | otherwise = NotValid why where - why = ptext (sLit "You need ") <> text flag_str - <+> ptext (sLit "to derive an instance for this class") + why = text "You need " <> text flag_str + <+> text "to derive an instance for this class" flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of [s] -> s other -> pprPanic "checkFlag" (ppr other) @@ -1381,7 +1381,7 @@ non_coercible_class cls , traversableClassKey, liftClassKey ]) badCon :: DataCon -> SDoc -> SDoc -badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg +badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg {- Note [Check that the type variable is truly universal] @@ -1500,8 +1500,8 @@ mkNewTypeEqn dflags overlap_mode tvs -- CanDerive/DerivableViaInstance _ -> do when (newtype_deriving && deriveAnyClass) $ - addWarnTc (sep [ ptext (sLit "Both DeriveAnyClass and GeneralizedNewtypeDeriving are enabled") - , ptext (sLit "Defaulting to the DeriveAnyClass strategy for instantiating") <+> ppr cls ]) + addWarnTc (sep [ text "Both DeriveAnyClass and GeneralizedNewtypeDeriving are enabled" + , text "Defaulting to the DeriveAnyClass strategy for instantiating" <+> ppr cls ]) go_for_it where newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags @@ -1512,7 +1512,7 @@ mkNewTypeEqn dflags overlap_mode tvs bale_out' b = failWithTc . derivingThingErr b cls cls_tys inst_ty non_std = nonStdErr cls - suggest_gnd = ptext (sLit "Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension") + suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension" -- Here is the plan for newtype derivings. We see -- newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...) @@ -1623,8 +1623,8 @@ mkNewTypeEqn dflags overlap_mode tvs cant_derive_err = vcat [ ppUnless eta_ok eta_msg , ppUnless ats_ok ats_msg ] - eta_msg = ptext (sLit "cannot eta-reduce the representation type enough") - ats_msg = ptext (sLit "the class has associated types") + eta_msg = text "cannot eta-reduce the representation type enough" + ats_msg = text "the class has associated types" {- Note [Recursive newtypes] @@ -1846,7 +1846,7 @@ simplifyDeriv pred tvs theta ; let skol_set = mkVarSet tvs_skols skol_info = DerivSkol pred - doc = ptext (sLit "deriving") <+> parens (ppr pred) + doc = text "deriving" <+> parens (ppr pred) mk_ct (PredOrigin t o t_or_k) = newWanted o (Just t_or_k) (substTy skol_subst t) @@ -2137,7 +2137,7 @@ getDataConFixityFun tc ; return (mi_fix iface . nameOccName) } } where name = tyConName tc - doc = ptext (sLit "Data con fixities for") <+> ppr name + doc = text "Data con fixities for" <+> ppr name {- Note [Bindings for Generalised Newtype Deriving] @@ -2194,41 +2194,41 @@ the empty instance declaration case). -} derivingNullaryErr :: MsgDoc -derivingNullaryErr = ptext (sLit "Cannot derive instances for nullary classes") +derivingNullaryErr = text "Cannot derive instances for nullary classes" derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> MsgDoc derivingKindErr tc cls cls_tys cls_kind - = hang (ptext (sLit "Cannot derive well-kinded instance of form") - <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> ptext (sLit "...")))) - 2 (ptext (sLit "Class") <+> quotes (ppr cls) - <+> ptext (sLit "expects an argument of kind") <+> quotes (pprKind cls_kind)) + = hang (text "Cannot derive well-kinded instance of form" + <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> text "..."))) + 2 (text "Class" <+> quotes (ppr cls) + <+> text "expects an argument of kind" <+> quotes (pprKind cls_kind)) derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc derivingEtaErr cls cls_tys inst_ty - = sep [ptext (sLit "Cannot eta-reduce to an instance of form"), - nest 2 (ptext (sLit "instance (...) =>") + = sep [text "Cannot eta-reduce to an instance of form", + nest 2 (text "instance (...) =>" <+> pprClassPred cls (cls_tys ++ [inst_ty]))] derivingThingErr :: Bool -> Class -> [Type] -> Type -> MsgDoc -> MsgDoc derivingThingErr newtype_deriving clas tys ty why - = sep [(hang (ptext (sLit "Can't make a derived instance of")) + = sep [(hang (text "Can't make a derived instance of") 2 (quotes (ppr pred)) $$ nest 2 extra) <> colon, nest 2 why] where - extra | newtype_deriving = ptext (sLit "(even with cunning GeneralizedNewtypeDeriving)") + extra | newtype_deriving = text "(even with cunning GeneralizedNewtypeDeriving)" | otherwise = Outputable.empty pred = mkClassPred clas (tys ++ [ty]) derivingHiddenErr :: TyCon -> SDoc derivingHiddenErr tc - = hang (ptext (sLit "The data constructors of") <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope")) - 2 (ptext (sLit "so you cannot derive an instance for it")) + = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope")) + 2 (text "so you cannot derive an instance for it") standaloneCtxt :: LHsSigType Name -> SDoc -standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) +standaloneCtxt ty = hang (text "In the stand-alone deriving instance for") 2 (quotes (ppr ty)) derivInstCtxt :: PredType -> MsgDoc derivInstCtxt pred - = ptext (sLit "When deriving the instance for") <+> parens (ppr pred) + = text "When deriving the instance for" <+> parens (ppr pred) diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 17a9b9bf97..f86156b1b1 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -221,13 +221,13 @@ tcLookupInstance :: Class -> [Type] -> TcM ClsInst tcLookupInstance cls tys = do { instEnv <- tcGetInstEnvs ; case lookupUniqueInstEnv instEnv cls tys of - Left err -> failWithTc $ ptext (sLit "Couldn't match instance:") <+> err + Left err -> failWithTc $ text "Couldn't match instance:" <+> err Right (inst, tys) | uniqueTyVars tys -> return inst | otherwise -> failWithTc errNotExact } where - errNotExact = ptext (sLit "Not an exact match (i.e., some variables get instantiated)") + errNotExact = text "Not an exact match (i.e., some variables get instantiated)" uniqueTyVars tys = all isTyVarTy tys && hasNoDups (map (getTyVar "tcLookupInstance") tys) @@ -675,16 +675,16 @@ checkWellStaged pp_thing bind_lvl use_lvl | otherwise -- Badly staged = failWithTc $ -- E.g. \x -> $(f x) - ptext (sLit "Stage error:") <+> pp_thing <+> - hsep [ptext (sLit "is bound at stage") <+> ppr bind_lvl, - ptext (sLit "but used at stage") <+> ppr use_lvl] + text "Stage error:" <+> pp_thing <+> + hsep [text "is bound at stage" <+> ppr bind_lvl, + text "but used at stage" <+> ppr use_lvl] stageRestrictionError :: SDoc -> TcM a stageRestrictionError pp_thing = failWithTc $ - sep [ ptext (sLit "GHC stage restriction:") - , nest 2 (vcat [ pp_thing <+> ptext (sLit "is used in a top-level splice, quasi-quote, or annotation,") - , ptext (sLit "and must be imported, not defined locally")])] + sep [ text "GHC stage restriction:" + , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation," + , text "and must be imported, not defined locally"])] topIdLvl :: Id -> ThLevel -- Globals may either be imported, or may be from an earlier "chunk" @@ -822,7 +822,7 @@ instance OutputableBndr a => Outputable (InstInfo a) where pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc pprInstInfoDetails info - = hang (pprInstanceHdr (iSpec info) <+> ptext (sLit "where")) + = hang (pprInstanceHdr (iSpec info) <+> text "where") 2 (details (iBinds info)) where details (InstBindings { ib_binds = b }) = pprLHsBinds b @@ -957,9 +957,9 @@ notFound name ; case stage of -- See Note [Out of scope might be a staging error] Splice {} -> stageRestrictionError (quotes (ppr name)) _ -> failWithTc $ - vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> - ptext (sLit "is not in scope during type checking, but it passed the renamer"), - ptext (sLit "tcl_env of environment:") <+> ppr (tcl_env lcl_env)] + vcat[text "GHC internal error:" <+> quotes (ppr name) <+> + text "is not in scope during type checking, but it passed the renamer", + text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)] -- Take care: printing the whole gbl env can -- cause an infinite loop, in the case where we -- are in the middle of a recursive TyCon/Class group; @@ -973,7 +973,7 @@ wrongThingErr :: String -> TcTyThing -> Name -> TcM a -- See Note [Placeholder PatSyn kinds] in TcBinds wrongThingErr expected thing name = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> - ptext (sLit "used as a") <+> text expected) + text "used as a" <+> text expected) {- Note [Out of scope might be a staging error] diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index a878aa7f95..8a2b0ad6df 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -324,7 +324,7 @@ warnRedundantConstraints ctxt env info ev_vars | SigSkol {} <- info = setLclEnv env $ -- We want to add "In the type signature for f" -- to the error context, which is a bit tiresome - addErrCtxt (ptext (sLit "In") <+> ppr info) $ + addErrCtxt (text "In" <+> ppr info) $ do { env <- getLclEnv ; msg <- mkErrorReport ctxt env (important doc) ; reportWarning msg } @@ -335,7 +335,7 @@ warnRedundantConstraints ctxt env info ev_vars = do { msg <- mkErrorReport ctxt env (important doc) ; reportWarning msg } where - doc = ptext (sLit "Redundant constraint") <> plural redundant_evs <> colon + doc = text "Redundant constraint" <> plural redundant_evs <> colon <+> pprEvVarTheta redundant_evs redundant_evs = case info of -- See Note [Redundant constraints in instance decls] @@ -364,8 +364,8 @@ This only matters in instance declarations.. reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM () reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl = implics }) - = do { traceTc "reportWanteds" (vcat [ ptext (sLit "Simples =") <+> ppr simples - , ptext (sLit "Suppress =") <+> ppr (cec_suppress ctxt)]) + = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples + , text "Suppress =" <+> ppr (cec_suppress ctxt)]) ; let tidy_cts = bagToList (mapBag (tidyCt env) (insols `unionBags` simples)) -- First deal with things that are utterly wrong @@ -860,30 +860,30 @@ mkHoleError ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort }) | otherwise = hang herald 2 pp_with_type pp_with_type = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty) - herald | isDataOcc occ = ptext (sLit "Data constructor not in scope:") - | otherwise = ptext (sLit "Variable not in scope:") + herald | isDataOcc occ = text "Data constructor not in scope:" + | otherwise = text "Variable not in scope:" hole_msg = case hole_sort of - ExprHole -> vcat [ hang (ptext (sLit "Found hole:")) + ExprHole -> vcat [ hang (text "Found hole:") 2 pp_with_type , tyvars_msg, expr_hole_hint ] - TypeHole -> vcat [ hang (ptext (sLit "Found type wildcard") <+> quotes (ppr occ)) - 2 (ptext (sLit "standing for") <+> quotes (pprType hole_ty)) + TypeHole -> vcat [ hang (text "Found type wildcard" <+> quotes (ppr occ)) + 2 (text "standing for" <+> quotes (pprType hole_ty)) , tyvars_msg, type_hole_hint ] tyvars_msg = ppUnless (null tyvars) $ - ptext (sLit "Where:") <+> vcat (map loc_msg tyvars) + text "Where:" <+> vcat (map loc_msg tyvars) type_hole_hint | HoleError <- cec_type_holes ctxt - = ptext (sLit "To use the inferred type, enable PartialTypeSignatures") + = text "To use the inferred type, enable PartialTypeSignatures" | otherwise = empty expr_hole_hint -- Give hint for, say, f x = _x | lengthFS (occNameFS occ) > 1 -- Don't give this hint for plain "_" - = ptext (sLit "Or perhaps") <+> quotes (ppr occ) - <+> ptext (sLit "is mis-spelled, or not in scope") + = text "Or perhaps" <+> quotes (ppr occ) + <+> text "is mis-spelled, or not in scope" | otherwise = empty @@ -891,7 +891,7 @@ mkHoleError ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort }) | isTyVar tv = case tcTyVarDetails tv of SkolemTv {} -> pprSkol (cec_encl ctxt) tv - MetaTv {} -> quotes (ppr tv) <+> ptext (sLit "is an ambiguous type variable") + MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable" det -> pprTcTyVarDetails det | otherwise = sdocWithDynFlags $ \dflags -> @@ -910,7 +910,7 @@ mkIPErr ctxt cts givens = getUserGivens ctxt msg | null givens = addArising orig $ - sep [ ptext (sLit "Unbound implicit parameter") <> plural cts + sep [ text "Unbound implicit parameter" <> plural cts , nest 2 (pprTheta preds) ] | otherwise = couldNotDeduce givens (preds, orig) @@ -988,7 +988,7 @@ mkEqErr1 ctxt ct -- with one from the implication. See Note [Inaccessible code] mk_given loc [] = (loc, empty) mk_given loc (implic : _) = (setCtLocEnv loc (ic_env implic) - , hang (ptext (sLit "Inaccessible code in")) + , hang (text "Inaccessible code in") 2 (ppr (ic_info implic))) -- If the types in the error message are the same as the types @@ -1146,10 +1146,10 @@ mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 ; mkErrorMsgFromCt ctxt ct $ mconcat [occCheckMsg, extra2, report] } | OC_Forall <- occ_check_expand - = do { let msg = vcat [ ptext (sLit "Cannot instantiate unification variable") + = do { let msg = vcat [ text "Cannot instantiate unification variable" <+> quotes (ppr tv1) , hang (text "with a" <+> what <+> text "involving foralls:") 2 (ppr ty2) - , nest 2 (ptext (sLit "GHC doesn't yet support impredicative polymorphism")) ] + , nest 2 (text "GHC doesn't yet support impredicative polymorphism") ] -- Unlike the other reports, this discards the old 'report_important' -- instead of augmenting it. This is because the details are not likely -- to be helpful since this is just an unimplemented feature. @@ -1176,9 +1176,9 @@ mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 = do { let msg = important $ misMatchMsg ct oriented ty1 ty2 esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols <+> pprQuotedList esc_skols - , ptext (sLit "would escape") <+> - if isSingleton esc_skols then ptext (sLit "its scope") - else ptext (sLit "their scope") ] + , text "would escape" <+> + if isSingleton esc_skols then text "its scope" + else text "their scope" ] tv_extra = important $ vcat [ nest 2 $ esc_doc , sep [ (if isSingleton esc_skols @@ -1186,9 +1186,9 @@ mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 what <+> text "variable is" else text "These (rigid, skolem)" <+> what <+> text "variables are") - <+> ptext (sLit "bound by") + <+> text "bound by" , nest 2 $ ppr skol_info - , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] ] + , nest 2 $ text "at" <+> ppr (tcl_loc env) ] ] ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) } -- Nastiest case: attempt to unify an untouchable variable @@ -1197,10 +1197,10 @@ mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 = do { let msg = important $ misMatchMsg ct oriented ty1 ty2 tclvl_extra = important $ nest 2 $ - sep [ quotes (ppr tv1) <+> ptext (sLit "is untouchable") - , nest 2 $ ptext (sLit "inside the constraints:") <+> pprEvVarTheta given - , nest 2 $ ptext (sLit "bound by") <+> ppr skol_info - , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] + sep [ quotes (ppr tv1) <+> text "is untouchable" + , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given + , nest 2 $ text "bound by" <+> ppr skol_info + , nest 2 $ text "at" <+> ppr (tcl_loc env) ] tv_extra = important $ extraTyVarInfo ctxt tv1 ty2 add_sig = important $ suggestAddSig ctxt ty1 ty2 ; mkErrorMsgFromCt ctxt ct $ mconcat @@ -1249,8 +1249,8 @@ mkEqInfoMsg ct ty1 ty2 tyfun_msg | Just tc1 <- mb_fun1 , Just tc2 <- mb_fun2 , tc1 == tc2 - = ptext (sLit "NB:") <+> quotes (ppr tc1) - <+> ptext (sLit "is a type function, and may not be injective") + = text "NB:" <+> quotes (ppr tc1) + <+> text "is a type function, and may not be injective" | otherwise = empty isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool @@ -1285,20 +1285,20 @@ misMatchOrCND ctxt ct oriented ty1 ty2 couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc couldNotDeduce givens (wanteds, orig) - = vcat [ addArising orig (ptext (sLit "Could not deduce:") <+> pprTheta wanteds) + = vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds) , vcat (pp_givens givens)] pp_givens :: [UserGiven] -> [SDoc] pp_givens givens = case givens of [] -> [] - (g:gs) -> ppr_given (ptext (sLit "from the context:")) g - : map (ppr_given (ptext (sLit "or from:"))) gs + (g:gs) -> ppr_given (text "from the context:") g + : map (ppr_given (text "or from:")) gs where ppr_given herald (gs, skol_info, _, loc) = hang (herald <+> pprEvVarTheta gs) - 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info - , ptext (sLit "at") <+> ppr loc]) + 2 (sep [ text "bound by" <+> ppr skol_info + , text "at" <+> ppr loc]) extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc -- Add on extra info about skolem constants @@ -1315,8 +1315,8 @@ extraTyVarInfo ctxt tv1 ty2 , let pp_tv = quotes (ppr tv) = case tcTyVarDetails tv of SkolemTv {} -> pprSkol implics tv - FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable") - RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem") + FlatSkol {} -> pp_tv <+> text "is a flattening type variable" + RuntimeUnk {} -> pp_tv <+> text "is an interactive-debugger skolem" MetaTv {} -> empty | otherwise -- Normal case @@ -1328,9 +1328,9 @@ suggestAddSig ctxt ty1 ty2 | null inferred_bndrs = empty | [bndr] <- inferred_bndrs - = ptext (sLit "Possible fix: add a type signature for") <+> quotes (ppr bndr) + = text "Possible fix: add a type signature for" <+> quotes (ppr bndr) | otherwise - = ptext (sLit "Possible fix: add type signatures for some or all of") <+> (ppr inferred_bndrs) + = text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs) where inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2) get_inf ty | Just tv <- tcGetTyVar_maybe ty @@ -1623,19 +1623,19 @@ sameOccExtra ty1 ty2 same_pkg = moduleUnitId (nameModule n1) == moduleUnitId (nameModule n2) , n1 /= n2 -- Different Names , same_occ -- but same OccName - = ptext (sLit "NB:") <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) + = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) | otherwise = empty where ppr_from same_pkg nm | isGoodSrcSpan loc - = hang (quotes (ppr nm) <+> ptext (sLit "is defined at")) + = hang (quotes (ppr nm) <+> text "is defined at") 2 (ppr loc) | otherwise -- Imported things have an UnhelpfulSrcSpan = hang (quotes (ppr nm)) - 2 (sep [ ptext (sLit "is defined in") <+> quotes (ppr (moduleName mod)) + 2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod)) , ppUnless (same_pkg || pkg == mainUnitId) $ - nest 4 $ ptext (sLit "in package") <+> quotes (ppr pkg) ]) + nest 4 $ text "in package" <+> quotes (ppr pkg) ]) where pkg = moduleUnitId mod mod = nameModule nm @@ -1803,7 +1803,7 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) = vcat [ ppWhen lead_with_ambig $ text "Probable fix: use a type annotation to specify what" <+> pprQuotedList ambig_tvs <+> text "should be." - , ptext (sLit "These potential instance") <> plural unifiers + , text "These potential instance" <> plural unifiers <+> text "exist:"] -- Report "potential instances" only when the constraint arises @@ -1814,24 +1814,24 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) add_to_ctxt_fixes has_ambig_tvs | not has_ambig_tvs && all_tyvars , (orig:origs) <- usefulContext ctxt pred - = [sep [ ptext (sLit "add") <+> pprParendType pred - <+> ptext (sLit "to the context of") + = [sep [ text "add" <+> pprParendType pred + <+> text "to the context of" , nest 2 $ ppr_skol orig $$ - vcat [ ptext (sLit "or") <+> ppr_skol orig + vcat [ text "or" <+> ppr_skol orig | orig <- origs ] ] ] | otherwise = [] - ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc) + ppr_skol (PatSkol dc _) = text "the data constructor" <+> quotes (ppr dc) ppr_skol skol_info = ppr skol_info extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys) - = ptext (sLit "(maybe you haven't applied a function to enough arguments?)") + = text "(maybe you haven't applied a function to enough arguments?)" | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T) , [_,ty] <- tys -- Look for (Typeable (k->*) (T k)) , Just (tc,_) <- tcSplitTyConApp_maybe ty , not (isTypeFamilyTyCon tc) - = hang (ptext (sLit "GHC can't yet do polykinded")) - 2 (ptext (sLit "Typeable") <+> + = hang (text "GHC can't yet do polykinded") + 2 (text "Typeable" <+> parens (ppr ty <+> dcolon <+> ppr (typeKind ty))) | otherwise = empty @@ -1842,22 +1842,22 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) DerivOriginCoerce {} -> [drv_fix] _ -> [] - drv_fix = hang (ptext (sLit "use a standalone 'deriving instance' declaration,")) - 2 (ptext (sLit "so you can specify the instance context yourself")) + drv_fix = hang (text "use a standalone 'deriving instance' declaration,") + 2 (text "so you can specify the instance context yourself") -- Normal overlap error overlap_msg = ASSERT( not (null matches) ) - vcat [ addArising orig (ptext (sLit "Overlapping instances for") + vcat [ addArising orig (text "Overlapping instances for" <+> pprType (mkClassPred clas tys)) , ppUnless (null matching_givens) $ - sep [ptext (sLit "Matching givens (or their superclasses):") + sep [text "Matching givens (or their superclasses):" , nest 2 (vcat matching_givens)] , sdocWithDynFlags $ \dflags -> getPprStyle $ \sty -> - pprPotentials dflags sty (ptext (sLit "Matching instances:")) $ + pprPotentials dflags sty (text "Matching instances:") $ ispecs ++ unifiers , ppWhen (null matching_givens && isSingleton matches && null unifiers) $ @@ -1867,15 +1867,15 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) -- constraints are non-flat and non-rewritten so we -- simply report back the whole given -- context. Accelerate Smart.hs showed this problem. - sep [ ptext (sLit "There exists a (perhaps superclass) match:") + sep [ text "There exists a (perhaps superclass) match:" , nest 2 (vcat (pp_givens givens))] , ppWhen (isSingleton matches) $ - parens (vcat [ ptext (sLit "The choice depends on the instantiation of") <+> + parens (vcat [ text "The choice depends on the instantiation of" <+> quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys)) , ppWhen (null (matching_givens)) $ - vcat [ ptext (sLit "To pick the first instance above, use IncoherentInstances") - , ptext (sLit "when compiling the other instance declarations")] + vcat [ text "To pick the first instance above, use IncoherentInstances" + , text "when compiling the other instance declarations"] ])] where givens = getUserGivens ctxt @@ -1885,8 +1885,8 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) = case ev_vars_matching of [] -> Nothing _ -> Just $ hang (pprTheta ev_vars_matching) - 2 (sep [ ptext (sLit "bound by") <+> ppr skol_info - , ptext (sLit "at") <+> ppr loc]) + 2 (sep [ text "bound by" <+> ppr skol_info + , text "at" <+> ppr loc]) where ev_vars_matching = filter ev_var_matches (map evVarPred evvars) ev_var_matches ty = case getClassPredTys_maybe ty of Just (clas', tys') @@ -1900,17 +1900,18 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) -- Overlap error because of Safe Haskell (first -- match should be the most specific match) safe_haskell_msg - = ASSERT( length matches == 1 && not (null unsafe_ispecs) ) - vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for") - <+> pprType (mkClassPred clas tys)) - , sep [ptext (sLit "The matching instance is:"), - nest 2 (pprInstance $ head ispecs)] - , vcat [ ptext $ sLit "It is compiled in a Safe module and as such can only" - , ptext $ sLit "overlap instances from the same module, however it" - , ptext $ sLit "overlaps the following instances from different modules:" - , nest 2 (vcat [pprInstances $ unsafe_ispecs]) - ] - ] + = ASSERT( length matches == 1 && not (null unsafe_ispecs) ) + vcat [ addArising orig (text "Unsafe overlapping instances for" + <+> pprType (mkClassPred clas tys)) + , sep [text "The matching instance is:", + nest 2 (pprInstance $ head ispecs)] + , vcat [ text "It is compiled in a Safe module and as such can only" + , text "overlap instances from the same module, however it" + , text "overlaps the following instances from different" <+> + text "modules:" + , nest 2 (vcat [pprInstances $ unsafe_ispecs]) + ] + ] {- Note [Highlighting ambiguous type variables] ----------------------------------------------- @@ -1955,8 +1956,8 @@ usefulContext ctxt pred show_fixes :: [SDoc] -> SDoc show_fixes [] = empty -show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:") - , nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))] +show_fixes (f:fs) = sep [ text "Possible fix:" + , nest 2 (vcat (f : map (text "or" <+>) fs))] pprPotentials :: DynFlags -> PprStyle -> SDoc -> [ClsInst] -> SDoc -- See Note [Displaying potential instances] @@ -1973,9 +1974,9 @@ pprPotentials dflags sty herald insts = hang herald 2 (vcat [ pprInstances show_these , ppWhen (n_in_scope_hidden > 0) $ - ptext (sLit "...plus") - <+> speakNOf n_in_scope_hidden (ptext (sLit "other")) - , not_in_scope_msg (ptext (sLit "...plus")) + text "...plus" + <+> speakNOf n_in_scope_hidden (text "other") + , not_in_scope_msg (text "...plus") , flag_hint ]) where n_show = 3 :: Int @@ -2012,11 +2013,11 @@ pprPotentials dflags sty herald insts = empty | otherwise = hang (herald <+> speakNOf (length not_in_scope) - (ptext (sLit "instance involving out-of-scope types"))) + (text "instance involving out-of-scope types")) 2 (ppWhen show_potentials (pprInstances not_in_scope)) flag_hint = ppUnless (show_potentials || length show_these == length insts) $ - ptext (sLit "(use -fprint-potential-instances to see them all)") + text "(use -fprint-potential-instances to see them all)" {- Note [Displaying potential instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2076,46 +2077,46 @@ mkAmbigMsg prepend_msg ct msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] || any isRuntimeUnkSkol ambig_tvs - = vcat [ ptext (sLit "Cannot resolve unknown runtime type") + = vcat [ text "Cannot resolve unknown runtime type" <> plural ambig_tvs <+> pprQuotedList ambig_tvs - , ptext (sLit "Use :print or :force to determine these types")] + , text "Use :print or :force to determine these types"] | not (null ambig_tvs) - = pp_ambig (ptext (sLit "type")) ambig_tvs + = pp_ambig (text "type") ambig_tvs | otherwise -- All ambiguous kind variabes; suggest -fprint-explicit-kinds - = vcat [ pp_ambig (ptext (sLit "kind")) ambig_kvs + = vcat [ pp_ambig (text "kind") ambig_kvs , sdocWithDynFlags suggest_explicit_kinds ] pp_ambig what tkvs | prepend_msg -- "Ambiguous type variable 't0'" - = ptext (sLit "Ambiguous") <+> what <+> ptext (sLit "variable") + = text "Ambiguous" <+> what <+> text "variable" <> plural tkvs <+> pprQuotedList tkvs | otherwise -- "The type variable 't0' is ambiguous" - = ptext (sLit "The") <+> what <+> ptext (sLit "variable") <> plural tkvs - <+> pprQuotedList tkvs <+> is_or_are tkvs <+> ptext (sLit "ambiguous") + = text "The" <+> what <+> text "variable" <> plural tkvs + <+> pprQuotedList tkvs <+> is_or_are tkvs <+> text "ambiguous" is_or_are [_] = text "is" is_or_are _ = text "are" suggest_explicit_kinds dflags -- See Note [Suggest -fprint-explicit-kinds] | gopt Opt_PrintExplicitKinds dflags = empty - | otherwise = ptext (sLit "Use -fprint-explicit-kinds to see the kind arguments") + | otherwise = text "Use -fprint-explicit-kinds to see the kind arguments" pprSkol :: [Implication] -> TcTyVar -> SDoc pprSkol implics tv | (skol_tvs, skol_info) <- getSkolemInfo implics tv = case skol_info of - UnkSkol -> pp_tv <+> ptext (sLit "is an unknown type variable") + UnkSkol -> pp_tv <+> text "is an unknown type variable" SigSkol ctxt ty -> ppr_rigid (pprSigSkolInfo ctxt (mkSpecForAllTys skol_tvs ty)) _ -> ppr_rigid (pprSkolInfo skol_info) where pp_tv = quotes (ppr tv) - ppr_rigid pp_info = hang (pp_tv <+> ptext (sLit "is a rigid type variable bound by")) + ppr_rigid pp_info = hang (pp_tv <+> text "is a rigid type variable bound by") 2 (sep [ pp_info - , ptext (sLit "at") <+> ppr (getSrcLoc tv) ]) + , text "at" <+> ppr (getSrcLoc tv) ]) getAmbigTkvs :: Ct -> ([Var],[Var]) getAmbigTkvs ct @@ -2176,7 +2177,7 @@ relevantBindings want_filtering ctxt ct -- which are probably the most relevant ones ; let doc = ppUnless (null docs) $ - hang (ptext (sLit "Relevant bindings include")) + hang (text "Relevant bindings include") 2 (vcat docs $$ ppWhen discards discardMsg) -- Put a zonked, tidied CtOrigin into the Ct @@ -2209,7 +2210,7 @@ relevantBindings want_filtering ctxt ct ; traceTc "relevantBindings 1" (ppr id <+> dcolon <+> ppr tidy_ty) ; let id_tvs = tyCoVarsOfType tidy_ty doc = sep [ pprPrefixOcc id <+> dcolon <+> ppr tidy_ty - , nest 2 (parens (ptext (sLit "bound at") + , nest 2 (parens (text "bound at" <+> ppr (getSrcLoc id)))] new_seen = tvs_seen `unionVarSet` id_tvs @@ -2233,7 +2234,8 @@ relevantBindings want_filtering ctxt ct else go tidy_env' ct_tvs (dec_max n_left) new_seen (doc:docs) discards tc_bndrs } discardMsg :: SDoc -discardMsg = ptext (sLit "(Some bindings suppressed; use -fmax-relevant-binds=N or -fno-max-relevant-binds)") +discardMsg = text "(Some bindings suppressed;" <+> + text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" ----------------------- warnDefaulting :: [Ct] -> Type -> TcM () diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index cca1684a24..517e724e69 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -652,7 +652,7 @@ Important Details: mkEvCast :: EvTerm -> TcCoercion -> EvTerm mkEvCast ev lco - | ASSERT2(tcCoercionRole lco == Representational, (vcat [ptext (sLit "Coercion of wrong role passed to mkEvCast:"), ppr ev, ppr lco])) + | ASSERT2(tcCoercionRole lco == Representational, (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco])) isTcReflCo lco = ev | otherwise = EvCast ev lco @@ -725,7 +725,7 @@ evVarsOfTypeable ev = -} instance Outputable HsWrapper where - ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn + ppr co_fn = pprHsWrapper (text "<>") co_fn pprHsWrapper :: SDoc -> HsWrapper -> SDoc -- In debug mode, print the wrapper @@ -741,15 +741,15 @@ pprHsWrapper doc wrap -- False <=> appears as body of let or lambda help it WpHole = it help it (WpCompose f1 f2) = help (help it f2) f1 - help it (WpFun f1 f2 t1) = add_parens $ ptext (sLit "\\(x") <> dcolon <> ppr t1 <> ptext (sLit ").") <+> - help (\_ -> it True <+> help (\_ -> ptext (sLit "x")) f1 True) f2 False - help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>") + help it (WpFun f1 f2 t1) = add_parens $ text "\\(x" <> dcolon <> ppr t1 <> text ")." <+> + help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False + help it (WpCast co) = add_parens $ sep [it False, nest 2 (text "|>" <+> pprParendCo co)] help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] - help it (WpTyApp ty) = no_parens $ sep [it True, ptext (sLit "@") <+> pprParendType ty] - help it (WpEvLam id) = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False] - help it (WpTyLam tv) = add_parens $ sep [ptext (sLit "/\\") <> pp_bndr tv, it False] - help it (WpLet binds) = add_parens $ sep [ptext (sLit "let") <+> braces (ppr binds), it False] + help it (WpTyApp ty) = no_parens $ sep [it True, text "@" <+> pprParendType ty] + help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pp_bndr id, it False] + help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pp_bndr tv, it False] + help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False] pp_bndr v = pprBndr LambdaBind v <> dot @@ -760,10 +760,10 @@ pprHsWrapper doc wrap instance Outputable TcEvBinds where ppr (TcEvBinds v) = ppr v - ppr (EvBinds bs) = ptext (sLit "EvBinds") <> braces (vcat (map ppr (bagToList bs))) + ppr (EvBinds bs) = text "EvBinds" <> braces (vcat (map ppr (bagToList bs))) instance Outputable EvBindsVar where - ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u) + ppr (EvBindsVar _ u) = text "EvBindsVar" <> angleBrackets (ppr u) instance Uniquable EvBindsVar where getUnique (EvBindsVar _ u) = u @@ -778,15 +778,15 @@ instance Outputable EvBind where instance Outputable EvTerm where ppr (EvId v) = ppr v - ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendCo co - ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co - ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) + ppr (EvCast v co) = ppr v <+> (text "`cast`") <+> pprParendCo co + ppr (EvCoercion co) = text "CO" <+> ppr co + ppr (EvSuperClass d n) = text "sc" <> parens (ppr (d,n)) ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] ppr (EvLit l) = ppr l ppr (EvCallStack cs) = ppr cs - ppr (EvDelayedError ty msg) = ptext (sLit "error") + ppr (EvDelayedError ty msg) = text "error" <+> sep [ char '@' <> ppr ty, ppr msg ] - ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> ptext (sLit "Typeable") <+> ppr ty + ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty instance Outputable EvLit where ppr (EvNum n) = integer n @@ -794,14 +794,14 @@ instance Outputable EvLit where instance Outputable EvCallStack where ppr EvCsEmpty - = ptext (sLit "[]") + = text "[]" ppr (EvCsPushCall name loc tm) - = ppr (name,loc) <+> ptext (sLit ":") <+> ppr tm + = ppr (name,loc) <+> text ":" <+> ppr tm instance Outputable EvTypeable where - ppr (EvTypeableTyCon ts) = ptext (sLit "TC") <+> ppr ts + ppr (EvTypeableTyCon ts) = text "TC" <+> ppr ts ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2) - ppr (EvTypeableTyLit t1) = ptext (sLit "TyLit") <> ppr t1 + ppr (EvTypeableTyLit t1) = text "TyLit" <> ppr t1 ---------------------------------------------------------------------- diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 575e1920fc..125d455701 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -230,11 +230,11 @@ tcExpr (HsLam match) res_ty ; return (mkHsWrap co_fn (HsLam match')) } where match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } - herald = sep [ ptext (sLit "The lambda expression") <+> + herald = sep [ text "The lambda expression" <+> quotes (pprSetDepth (PartWay 1) $ pprMatches (LambdaExpr :: HsMatchContext Name) match), -- The pprSetDepth makes the abstraction print briefly - ptext (sLit "has")] + text "has"] tcExpr e@(HsLamCase _ matches) res_ty = do { (co_fn, ~[arg_ty], matches') @@ -242,8 +242,8 @@ tcExpr e@(HsLamCase _ matches) res_ty -- The laziness annotation is because we don't want to fail here -- if there are multiple arguments ; return (mkHsWrap co_fn $ HsLamCase arg_ty matches') } - where msg = sep [ ptext (sLit "The function") <+> quotes (ppr e) - , ptext (sLit "requires")] + where msg = sep [ text "The function" <+> quotes (ppr e) + , text "requires"] match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } tcExpr e@(ExprWithTySig expr sig_ty) res_ty @@ -343,7 +343,7 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty = do { traceTc "Application rule" (ppr op) ; (arg1', arg1_ty) <- tcInferSigma arg1 - ; let doc = ptext (sLit "The first argument of ($) takes") + ; let doc = text "The first argument of ($) takes" orig1 = exprCtOrigin (unLoc arg1) ; (wrap_arg1, [arg2_sigma], op_res_ty) <- matchActualFunTys doc orig1 1 arg1_ty @@ -557,7 +557,7 @@ tcExpr (HsStatic expr) res_ty = do { staticPtrTyCon <- tcLookupTyCon staticPtrTyConName ; (co, [expr_ty]) <- matchExpectedTyConApp staticPtrTyCon res_ty ; (expr', lie) <- captureConstraints $ - addErrCtxt (hang (ptext (sLit "In the body of a static form:")) + addErrCtxt (hang (text "In the body of a static form:") 2 (ppr expr) ) $ tcPolyExprNC expr expr_ty @@ -1097,8 +1097,8 @@ tcApp m_herald orig_fun orig_args res_ty ; return (wrap_res, mkLHsWrap wrap_fun fun1, args1) } mk_app_msg :: LHsExpr Name -> SDoc -mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun) - , ptext (sLit "is applied to")] +mk_app_msg fun = sep [ text "The function" <+> quotes (ppr fun) + , text "is applied to"] mk_op_msg :: LHsExpr Name -> SDoc mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes" @@ -1330,7 +1330,7 @@ tcInferId :: Name -> TcM (HsExpr TcId, TcSigmaType) -- Look up an occurrence of an Id tcInferId id_name | id_name `hasKey` tagToEnumKey - = failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument")) + = failWithTc (text "tagToEnum# must appear applied to one argument") -- tcApp catches the case (tagToEnum# arg) | id_name `hasKey` assertIdKey @@ -1375,7 +1375,7 @@ tc_infer_id lbl id_name PatSynCon ps -> tcPatSynBuilderOcc ps _ -> failWithTc $ - ppr thing <+> ptext (sLit "used where a value identifier was expected") } + ppr thing <+> text "used where a value identifier was expected" } where return_id id = return (HsVar (noLoc id), idType id) @@ -1562,14 +1562,14 @@ tcTagToEnum loc fun_name args res_ty ; return (mkWpCastR (mkTcSymCo coi), fun', [arg']) } -- coi is a Representational coercion where - 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") + doc1 = vcat [ text "Specify the type by giving a type signature" + , text "e.g. (tagToEnum# x) :: Bool" ] + doc2 = text "Result type must be an enumeration type" mk_error :: TcType -> SDoc -> SDoc mk_error ty what - = hang (ptext (sLit "Bad call to tagToEnum#") - <+> ptext (sLit "at type") <+> ppr ty) + = hang (text "Bad call to tagToEnum#" + <+> text "at type" <+> ppr ty) 2 what too_many_args :: TcM a @@ -1648,7 +1648,7 @@ checkCrossStageLifting _ _ = return () polySpliceErr :: Id -> SDoc polySpliceErr id - = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id) + = text "Can't splice the polymorphic local variable" <+> quotes (ppr id) {- Note [Lifting strings] @@ -2091,11 +2091,11 @@ addExprErrCtxt expr = addErrCtxt (exprCtxt expr) exprCtxt :: LHsExpr Name -> SDoc exprCtxt expr - = hang (ptext (sLit "In the expression:")) 2 (ppr expr) + = hang (text "In the expression:") 2 (ppr expr) fieldCtxt :: FieldLabelString -> SDoc fieldCtxt field_name - = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") + = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") addFunResCtxt :: Bool -- There is at least one argument -> HsExpr Name -> TcType -> TcType @@ -2121,13 +2121,13 @@ addFunResCtxt has_args fun fun_res_ty env_ty info | n_fun == n_env = Outputable.empty | n_fun > n_env , not_fun res_env - = ptext (sLit "Probable cause:") <+> quotes (ppr fun) - <+> ptext (sLit "is applied to too few arguments") + = text "Probable cause:" <+> quotes (ppr fun) + <+> text "is applied to too few arguments" | has_args , not_fun res_fun - = ptext (sLit "Possible cause:") <+> quotes (ppr fun) - <+> ptext (sLit "is applied to too many arguments") + = text "Possible cause:" <+> quotes (ppr fun) + <+> text "is applied to too many arguments" | otherwise = Outputable.empty -- Never suggest that a naked variable is -- applied to too many args! @@ -2141,7 +2141,7 @@ addFunResCtxt has_args fun fun_res_ty env_ty badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc badFieldTypes prs - = hang (ptext (sLit "Record update for insufficiently polymorphic field") + = hang (text "Record update for insufficiently polymorphic field" <> plural prs <> colon) 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) @@ -2150,7 +2150,7 @@ badFieldsUpd -> [ConLike] -- Data cons of the type which the first field name belongs to -> SDoc badFieldsUpd rbinds data_cons - = hang (ptext (sLit "No constructor has all these fields:")) + = hang (text "No constructor has all these fields:") 2 (pprQuotedList conflictingFields) -- See Note [Finding the conflicting fields] where @@ -2222,23 +2222,23 @@ a decent stab, no more. See Trac #7989. naughtyRecordSel :: RdrName -> 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") + = text "Cannot use record selector" <+> quotes (ppr sel_id) <+> + text "as a function due to escaped type variables" $$ + text "Probable fix: use pattern-matching syntax instead" notSelector :: Name -> SDoc notSelector field - = hsep [quotes (ppr field), ptext (sLit "is not a record selector")] + = hsep [quotes (ppr field), text "is not a record selector"] mixedSelectors :: [Id] -> [Id] -> SDoc mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) = ptext (sLit "Cannot use a mixture of pattern synonym and record selectors") $$ - ptext (sLit "Record selectors defined by") + text "Record selectors defined by" <+> quotes (ppr (tyConName rep_dc)) <> text ":" <+> pprWithCommas ppr data_sels $$ - ptext (sLit "Pattern synonym selectors defined by") + text "Pattern synonym selectors defined by" <+> quotes (ppr (patSynName rep_ps)) <> text ":" <+> pprWithCommas ppr pat_syn_sels @@ -2256,26 +2256,26 @@ 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 = text "Constructor" <+> quotes (ppr con) <+> + text "does not have the required strict field(s)" missingFields :: ConLike -> [FieldLabelString] -> SDoc missingFields con fields - = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:") + = text "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 = text "In the call" <+> parens (ppr (foldl mkHsApp fun args)) noPossibleParents :: [LHsRecUpdField Name] -> SDoc noPossibleParents rbinds - = hang (ptext (sLit "No type has all these fields:")) + = hang (text "No type has all these fields:") 2 (pprQuotedList fields) where fields = map (hsRecFieldLbl . unLoc) rbinds badOverloadedUpdate :: SDoc -badOverloadedUpdate = ptext (sLit "Record update is ambiguous, and requires a type signature") +badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature" fieldNotInType :: RecSelParent -> RdrName -> SDoc fieldNotInType p rdr - = unknownSubordinateErr (ptext (sLit "field of type") <+> quotes (ppr p)) rdr + = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs index 06ef6930cf..f87a302d5c 100644 --- a/compiler/typecheck/TcFlatten.hs +++ b/compiler/typecheck/TcFlatten.hs @@ -26,7 +26,6 @@ import DynFlags( DynFlags ) import Util import Bag import Pair -import FastString import Control.Monad import MonadUtils ( zipWithAndUnzipM ) import GHC.Exts ( inline ) @@ -1439,8 +1438,8 @@ unflatten tv_eqs funeqs ; tclvl <- getTcLevel ; traceTcS "Unflattening" $ braces $ - vcat [ ptext (sLit "Funeqs =") <+> pprCts funeqs - , ptext (sLit "Tv eqs =") <+> pprCts tv_eqs ] + vcat [ text "Funeqs =" <+> pprCts funeqs + , text "Tv eqs =" <+> pprCts tv_eqs ] -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check -- Occurs check: consider [W] alpha ~ [F alpha] diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs index 3f10fe1c54..bc3a9283c6 100644 --- a/compiler/typecheck/TcForeign.hs +++ b/compiler/typecheck/TcForeign.hs @@ -57,7 +57,6 @@ import Outputable import Platform import SrcLoc import Bag -import FastString import Hooks import qualified GHC.LanguageExtensions as LangExt @@ -289,7 +288,7 @@ tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty - _ -> addErrTc (illegalForeignTyErr Outputable.empty (ptext (sLit "One argument expected"))) + _ -> addErrTc (illegalForeignTyErr Outputable.empty (text "One argument expected")) return (CImport (L lc cconv') safety mh CWrapper src) tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh @@ -299,7 +298,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh cconv' <- checkCConv cconv case arg_tys of -- The first arg must be Ptr or FunPtr [] -> - addErrTc (illegalForeignTyErr Outputable.empty (ptext (sLit "At least one argument expected"))) + addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected")) (arg1_ty:arg_tys) -> do dflags <- getDynFlags let curried_res_ty = mkFunTys arg_tys res_ty @@ -350,7 +349,7 @@ checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () checkMissingAmpersand dflags arg_tys res_ty | null arg_tys && isFunPtrTy res_ty && wopt Opt_WarnDodgyForeignImports dflags - = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr")) + = addWarn (text "possible missing & in foreign import of FunPtr") | otherwise = return () @@ -453,7 +452,7 @@ checkForeignRes non_io_result_ok check_safe pred_res_ty ty -- Case for non-IO result type with FFI Import | not non_io_result_ok - = addErrTc $ illegalForeignTyErr result (ptext (sLit "IO result type expected")) + = addErrTc $ illegalForeignTyErr result (text "IO result type expected") | otherwise = do { dflags <- getDynFlags @@ -473,7 +472,8 @@ checkForeignRes non_io_result_ok check_safe pred_res_ty ty -- success! non-IO return is fine _ -> return () } where - safeHsErr = ptext $ sLit "Safe Haskell is on, all FFI imports must be in the IO monad" + safeHsErr = + text "Safe Haskell is on, all FFI imports must be in the IO monad" nonIOok, mustBeIO :: Bool nonIOok = True @@ -542,8 +542,8 @@ illegalForeignTyErr :: SDoc -> SDoc -> SDoc illegalForeignTyErr arg_or_res extra = hang msg 2 extra where - msg = hsep [ ptext (sLit "Unacceptable"), arg_or_res - , ptext (sLit "type in foreign declaration:")] + msg = hsep [ text "Unacceptable", arg_or_res + , text "type in foreign declaration:"] -- Used for 'arg_or_res' argument to illegalForeignTyErr argument, result :: SDoc @@ -552,9 +552,9 @@ result = text "result" badCName :: CLabelString -> MsgDoc badCName target - = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")] + = sep [quotes (ppr target) <+> text "is not a valid C identifier"] foreignDeclCtxt :: ForeignDecl Name -> SDoc foreignDeclCtxt fo - = hang (ptext (sLit "When checking declaration:")) + = hang (text "When checking declaration:") 2 (ppr fo) diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index 2ebf3fda15..33c04b3693 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -235,8 +235,8 @@ canDoGenerics1 rep_tc tc_args = additionalChecks -- check (f) from Note [Requirements for deriving Generic and Rep] | null (tyConTyVars rep_tc) = NotValid $ - ptext (sLit "Data type") <+> quotes (ppr rep_tc) - <+> ptext (sLit "must have some type parameters") + text "Data type" <+> quotes (ppr rep_tc) + <+> text "must have some type parameters" | otherwise = mergeErrors $ concatMap check_con data_cons @@ -246,7 +246,7 @@ canDoGenerics1 rep_tc tc_args = IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con bad :: DataCon -> SDoc -> SDoc - bad con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg + bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg check_vanilla :: DataCon -> Validity check_vanilla con | isVanillaDataCon con = IsValid diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 06f1d4a5de..b301149c6a 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -226,7 +226,7 @@ tcHsDeriv hs_ty ; let (tvs, pred) = splitForAllTys ty ; case getClassPredTys_maybe pred of Just (cls, tys) -> return (tvs, cls, tys, arg_kind) - Nothing -> failWithTc (ptext (sLit "Illegal deriving item") <+> quotes (ppr hs_ty)) } + Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt -> LHsSigType Name @@ -266,7 +266,7 @@ tcHsVectInst ty return (cls, args) _ -> failWithTc (text "Too many arguments passed to" <+> ppr cls_name) } | otherwise - = failWithTc $ ptext (sLit "Malformed instance type") + = failWithTc $ text "Malformed instance type" ---------------------------------------------- -- | Type-check a visible type application @@ -489,15 +489,15 @@ tc_hs_type _ ty@(HsBangTy {}) _ -- While top-level bangs at this point are eliminated (eg !(Maybe Int)), -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of -- bangs are invalid, so fail. (#7210) - = failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty) + = failWithTc (text "Unexpected strictness annotation:" <+> ppr ty) tc_hs_type _ ty@(HsRecTy _) _ -- Record types (which only show up temporarily in constructor -- signatures) should have been removed by now - = failWithTc (ptext (sLit "Record syntax is illegal here:") <+> ppr ty) + = failWithTc (text "Record syntax is illegal here:" <+> ppr ty) -- This should never happen; type splices are expanded by the renamer tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind - = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty) + = failWithTc (text "Unexpected type splice:" <+> ppr ty) ---------- Functions and applications tc_hs_type mode (HsFunTy ty1 ty2) exp_kind @@ -511,7 +511,7 @@ tc_hs_type mode (HsOpTy ty1 (L _ op) ty2) exp_kind tc_hs_type mode hs_ty@(HsForAllTy { hst_bndrs = hs_tvs, hst_body = ty }) exp_kind -- Do not kind-generalise here. See Note [Kind generalisation] | isConstraintKind exp_kind - = failWithTc (hang (ptext (sLit "Illegal constraint:")) 2 (ppr hs_ty)) + = failWithTc (hang (text "Illegal constraint:") 2 (ppr hs_ty)) | otherwise = fmap fst $ @@ -714,9 +714,9 @@ finish_tuple tup_sort tau_tys tau_kinds exp_kind bigConstraintTuple :: Arity -> MsgDoc bigConstraintTuple arity - = hang (ptext (sLit "Constraint tuple arity too large:") <+> int arity - <+> parens (ptext (sLit "max arity =") <+> int mAX_CTUPLE_SIZE)) - 2 (ptext (sLit "Instead, use a nested tuple")) + = hang (text "Constraint tuple arity too large:" <+> int arity + <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE)) + 2 (text "Instead, use a nested tuple") --------------------------- -- | Apply a type of a given kind to a list of arguments. This instantiates @@ -1231,7 +1231,7 @@ addTypeCtxt :: LHsType Name -> TcM a -> TcM a addTypeCtxt (L _ ty) thing = addErrCtxt doc thing where - doc = ptext (sLit "In the type") <+> quotes (ppr ty) + doc = text "In the type" <+> quotes (ppr ty) {- ************************************************************************ @@ -1912,7 +1912,7 @@ tcDataKindSig kind badKindSig :: Kind -> SDoc badKindSig kind - = hang (ptext (sLit "Kind signature on data type declaration has non-* return kind")) + = hang (text "Kind signature on data type declaration has non-* return kind") 2 (ppr kind) {- @@ -2059,17 +2059,17 @@ tcPatSig in_pat_bind sig res_ty mk_msg sig_ty tidy_env = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty - ; let msg = vcat [ hang (ptext (sLit "When checking that the pattern signature:")) + ; let msg = vcat [ hang (text "When checking that the pattern signature:") 4 (ppr sig_ty) - , nest 2 (hang (ptext (sLit "fits the type of its context:")) + , nest 2 (hang (text "fits the type of its context:") 2 (ppr res_ty)) ] ; return (tidy_env, msg) } patBindSigErr :: [TcTyVar] -> SDoc patBindSigErr sig_tvs - = hang (ptext (sLit "You cannot bind scoped type variable") <> plural sig_tvs + = hang (text "You cannot bind scoped type variable" <> plural sig_tvs <+> pprQuotedList sig_tvs) - 2 (ptext (sLit "in a pattern binding signature")) + 2 (text "in a pattern binding signature") {- Note [Pattern signature binders] @@ -2151,12 +2151,12 @@ tcLHsKind = tc_lhs_kind kindLevelMode tc_lhs_kind :: TcTyMode -> LHsKind Name -> TcM Kind tc_lhs_kind mode k - = addErrCtxt (ptext (sLit "In the kind") <+> quotes (ppr k)) $ + = addErrCtxt (text "In the kind" <+> quotes (ppr k)) $ tc_lhs_type (kindLevel mode) k liftedTypeKind promotionErr :: Name -> PromotionErr -> TcM a promotionErr name err - = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> ptext (sLit "cannot be used here")) + = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here") 2 (parens reason)) where reason = case err of @@ -2177,12 +2177,12 @@ promotionErr name err badPatSigTvs :: TcType -> [TyVar] -> SDoc badPatSigTvs sig_ty bad_tvs - = vcat [ fsep [ptext (sLit "The type variable") <> plural bad_tvs, + = vcat [ fsep [text "The type variable" <> plural bad_tvs, quotes (pprWithCommas ppr bad_tvs), - ptext (sLit "should be bound by the pattern signature") <+> quotes (ppr sig_ty), - ptext (sLit "but are actually discarded by a type synonym") ] - , ptext (sLit "To fix this, expand the type synonym") - , ptext (sLit "[Note: I hope to lift this restriction in due course]") ] + text "should be bound by the pattern signature" <+> quotes (ppr sig_ty), + text "but are actually discarded by a type synonym" ] + , text "To fix this, expand the type synonym" + , text "[Note: I hope to lift this restriction in due course]" ] {- ************************************************************************ @@ -2196,6 +2196,6 @@ badPatSigTvs sig_ty bad_tvs -- Used for both expressions and types. funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc funAppCtxt fun arg arg_no - = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"), + = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"), quotes (ppr fun) <> text ", namely"]) 2 (quotes (ppr arg)) diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 5fc09eaa74..a1cff1d8e3 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -433,9 +433,9 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- Check for hand-written Generic instances (disallowed in Safe Haskell) genInstCheck ty = is_cls_nm (iSpec ty) `elem` genericClassNames - genInstErr i = hang (ptext (sLit $ "Generic instances can only be " + genInstErr i = hang (text ("Generic instances can only be " ++ "derived in Safe Haskell.") $+$ - ptext (sLit "Replace the following instance:")) + text "Replace the following instance:") 2 (pprInstanceHdr (iSpec i)) -- Report an error or a warning for a Typeable instances. @@ -449,11 +449,11 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls then do warn <- woptM Opt_WarnDerivingTypeable when warn $ addWarnTc $ vcat - [ ppTypeable <+> ptext (sLit "instances in .hs-boot files are ignored") - , ptext (sLit "This warning will become an error in future versions of the compiler") + [ ppTypeable <+> text "instances in .hs-boot files are ignored" + , text "This warning will become an error in future versions of the compiler" ] - else addErrTc $ ptext (sLit "Class") <+> ppTypeable - <+> ptext (sLit "does not support user-specified instances") + else addErrTc $ text "Class" <+> ppTypeable + <+> text "does not support user-specified instances" ppTypeable :: SDoc ppTypeable = quotes (ppr typeableClassName) @@ -1455,18 +1455,18 @@ methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) methSigCtxt sel_name sig_ty meth_ty env0 = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty - ; let msg = hang (ptext (sLit "When checking that instance signature for") <+> quotes (ppr sel_name)) - 2 (vcat [ ptext (sLit "is more general than its signature in the class") - , ptext (sLit "Instance sig:") <+> ppr sig_ty - , ptext (sLit " Class sig:") <+> ppr meth_ty ]) + ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name)) + 2 (vcat [ text "is more general than its signature in the class" + , text "Instance sig:" <+> ppr sig_ty + , text " Class sig:" <+> ppr meth_ty ]) ; return (env2, msg) } misplacedInstSig :: Name -> LHsSigType Name -> SDoc misplacedInstSig name hs_ty - = vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:")) + = vcat [ hang (text "Illegal type signature in instance declaration:") 2 (hang (pprPrefixName name) 2 (dcolon <+> ppr hs_ty)) - , ptext (sLit "(Use InstanceSigs to allow this)") ] + , text "(Use InstanceSigs to allow this)" ] {- Note [Instance method signatures] @@ -1544,10 +1544,10 @@ mkGenericDefMethBind clas inst_tys sel_id dm_name ---------------------- derivBindCtxt :: Id -> Class -> [Type ] -> SDoc derivBindCtxt sel_id clas tys - = vcat [ ptext (sLit "When typechecking the code for") <+> quotes (ppr sel_id) - , nest 2 (ptext (sLit "in a derived instance for") + = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id) + , nest 2 (text "in a derived instance for" <+> quotes (pprClassPred clas tys) <> colon) - , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ] + , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ] warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () warnUnsatisfiedMinimalDefinition mindef @@ -1555,7 +1555,7 @@ warnUnsatisfiedMinimalDefinition mindef ; warnTc warn message } where - message = vcat [ptext (sLit "No explicit implementation for") + message = vcat [text "No explicit implementation for" ,nest 2 $ pprBooleanFormulaNice mindef ] @@ -1743,7 +1743,7 @@ tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty) ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } where - spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) + spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag) tcSpecInst _ _ = panic "tcSpecInst" @@ -1767,34 +1767,34 @@ instDeclCtxt2 dfun_ty (_,_,cls,tys) = tcSplitDFunTy dfun_ty inst_decl_ctxt :: SDoc -> SDoc -inst_decl_ctxt doc = hang (ptext (sLit "In the instance declaration for")) +inst_decl_ctxt doc = hang (text "In the instance declaration for") 2 (quotes doc) badBootFamInstDeclErr :: SDoc badBootFamInstDeclErr - = ptext (sLit "Illegal family instance in hs-boot file") + = text "Illegal family instance in hs-boot file" notFamily :: TyCon -> SDoc notFamily tycon - = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon) - , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))] + = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon) + , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")] tooFewParmsErr :: Arity -> SDoc tooFewParmsErr arity - = ptext (sLit "Family instance has too few parameters; expected") <+> + = text "Family instance has too few parameters; expected" <+> ppr arity assocInClassErr :: Located Name -> SDoc assocInClassErr name - = ptext (sLit "Associated type") <+> quotes (ppr name) <+> - ptext (sLit "must be inside a class instance") + = text "Associated type" <+> quotes (ppr name) <+> + text "must be inside a class instance" badFamInstDecl :: Located Name -> SDoc badFamInstDecl tc_name - = vcat [ ptext (sLit "Illegal family instance for") <+> + = vcat [ text "Illegal family instance for" <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext (sLit "Use TypeFamilies to allow indexed type families")) ] + , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ] notOpenFamily :: TyCon -> SDoc notOpenFamily tc - = ptext (sLit "Illegal instance for closed family") <+> quotes (ppr tc) + = text "Illegal instance for closed family" <+> quotes (ppr tc) diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index 9722166565..8582c7298f 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -11,7 +11,6 @@ module TcInteract ( import BasicTypes ( infinity, IntWithInf, intGtLimit ) import HsTypes ( HsIPName(..) ) -import FastString import TcCanonical import TcFlatten import VarSet @@ -154,18 +153,18 @@ solveSimpleWanteds simples ; dflags <- getDynFlags ; (n,wc) <- go 1 (solverIterations dflags) (emptyWC { wc_simple = simples }) ; traceTcS "solveSimples end }" $ - vcat [ ptext (sLit "iterations =") <+> ppr n - , ptext (sLit "residual =") <+> ppr wc ] + vcat [ text "iterations =" <+> ppr n + , text "residual =" <+> ppr wc ] ; return wc } where go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints) go n limit wc | n `intGtLimit` limit - = failTcS (hang (ptext (sLit "solveSimpleWanteds: too many iterations") - <+> parens (ptext (sLit "limit =") <+> ppr limit)) - 2 (vcat [ ptext (sLit "Set limit with -fsolver-iterations=n; n=0 for no limit") - , ptext (sLit "Simples =") <+> ppr simples - , ptext (sLit "WC =") <+> ppr wc ])) + = failTcS (hang (text "solveSimpleWanteds: too many iterations" + <+> parens (text "limit =" <+> ppr limit)) + 2 (vcat [ text "Set limit with -fsolver-iterations=n; n=0 for no limit" + , text "Simples =" <+> ppr simples + , text "WC =" <+> ppr wc ])) | isEmptyBag (wc_simple wc) = return (n,wc) @@ -378,8 +377,8 @@ runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline runSolverPipeline pipeline workItem = do { initial_is <- getTcSInerts ; traceTcS "Start solver pipeline {" $ - vcat [ ptext (sLit "work item = ") <+> ppr workItem - , ptext (sLit "inerts = ") <+> ppr initial_is] + vcat [ text "work item = " <+> ppr workItem + , text "inerts = " <+> ppr initial_is] ; bumpStepCountTcS -- One step for each constraint processed ; final_res <- run_pipeline pipeline (ContinueWith workItem) @@ -388,13 +387,13 @@ runSolverPipeline pipeline workItem ; case final_res of Stop ev s -> do { traceFireTcS ev s ; traceTcS "End solver pipeline (discharged) }" - (ptext (sLit "inerts =") <+> ppr final_is) + (text "inerts =" <+> ppr final_is) ; return () } - ContinueWith ct -> do { traceFireTcS (ctEvidence ct) (ptext (sLit "Kept as inert")) + ContinueWith ct -> do { traceFireTcS (ctEvidence ct) (text "Kept as inert") ; traceTcS "End solver pipeline (kept as inert) }" $ - vcat [ ptext (sLit "final_item =") <+> ppr ct + vcat [ text "final_item =" <+> ppr ct , pprTvBndrs (varSetElems $ tyCoVarsOfCt ct) - , ptext (sLit "inerts =") <+> ppr final_is] + , text "inerts =" <+> ppr final_is] ; addInertCan ct } } where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct @@ -497,9 +496,9 @@ data InteractResult | IRDelete -- Delete the existing inert constraint from the inert set instance Outputable InteractResult where - ppr IRKeep = ptext (sLit "keep") - ppr IRReplace = ptext (sLit "replace") - ppr IRDelete = ptext (sLit "delete") + ppr IRKeep = text "keep" + ppr IRReplace = text "replace" + ppr IRDelete = text "delete" solveOneFromTheOther :: CtEvidence -- Inert -> CtEvidence -- WorkItem @@ -661,7 +660,7 @@ interactIrred inerts workItem@(CIrredEvCan { cc_ev = ev_w }) -- These const upd's assume that solveOneFromTheOther -- has no side effects on InertCans ; if stop_now then - return (Stop ev_w (ptext (sLit "Irred equal") <+> parens (ppr inert_effect))) + return (Stop ev_w (text "Irred equal" <+> parens (ppr inert_effect))) ; else continueWith workItem } @@ -712,7 +711,7 @@ interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs IRDelete -> updInertDicts $ \ ds -> delDict ds cls tys IRReplace -> updInertDicts $ \ ds -> addDict ds cls tys workItem ; if stop_now then - return (Stop ev_w (ptext (sLit "Dict equal") <+> parens (ppr inert_effect))) + return (Stop ev_w (text "Dict equal" <+> parens (ppr inert_effect))) else continueWith workItem } @@ -879,9 +878,9 @@ improveLocalFunEqs :: CtLoc -> InertCans -> TyCon -> [TcType] -> TcTyVar improveLocalFunEqs loc inerts fam_tc args fsk | not (null improvement_eqns) = do { traceTcS "interactFunEq improvements: " $ - vcat [ ptext (sLit "Eqns:") <+> ppr improvement_eqns - , ptext (sLit "Candidates:") <+> ppr funeqs_for_tc - , ptext (sLit "Model:") <+> ppr model ] + vcat [ text "Eqns:" <+> ppr improvement_eqns + , text "Candidates:" <+> ppr funeqs_for_tc + , text "Model:" <+> ppr model ] ; mapM_ (unifyDerived loc Nominal) improvement_eqns } | otherwise = return () @@ -1127,7 +1126,7 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv ; if canSolveByUnification tclvl ev eq_rel tv rhs then do { solveByUnification ev tv rhs ; n_kicked <- kickOutAfterUnification tv - ; return (Stop ev (ptext (sLit "Solved by unification") <+> ppr_kicked n_kicked)) } + ; return (Stop ev (text "Solved by unification" <+> ppr_kicked n_kicked)) } else do { traceTcS "Can't solve tyvar equality" (vcat [ text "LHS:" <+> ppr tv <+> dcolon <+> ppr (tyVarKind tv) @@ -1137,7 +1136,7 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv , text "RHS:" <+> ppr rhs <+> dcolon <+> ppr (typeKind rhs) , text "TcLevel =" <+> ppr tclvl ]) ; addInertEq workItem - ; return (Stop ev (ptext (sLit "Kept as inert"))) } } + ; return (Stop ev (text "Kept as inert")) } } interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi) @@ -1191,7 +1190,7 @@ solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS () solveByUnification wd tv xi = do { let tv_ty = mkTyVarTy tv ; traceTcS "Sneaky unification:" $ - vcat [text "Unifies:" <+> ppr tv <+> ptext (sLit ":=") <+> ppr xi, + vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr xi, text "Coercion:" <+> pprEq tv_ty xi, text "Left Kind is:" <+> ppr (typeKind tv_ty), text "Right Kind is:" <+> ppr (typeKind xi) ] @@ -1201,7 +1200,7 @@ solveByUnification wd tv xi ppr_kicked :: Int -> SDoc ppr_kicked 0 = empty -ppr_kicked n = parens (int n <+> ptext (sLit "kicked out")) +ppr_kicked n = parens (int n <+> text "kicked out") {- Note [Avoid double unifications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1273,7 +1272,7 @@ topReactionsStage wi = do { tir <- doTopReact wi ; case tir of ContinueWith wi -> continueWith wi - Stop ev s -> return (Stop ev (ptext (sLit "Top react:") <+> s)) } + Stop ev s -> return (Stop ev (text "Top react:" <+> s)) } doTopReact :: WorkItem -> TcS (StopOrContinue Ct) -- The work item does not react with the inert set, so try interaction with top-level diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index ae8923d6e6..7ab59be38d 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -894,7 +894,7 @@ skolemiseUnboundMetaTyVar tv details final_name = mkInternalName uniq tv_name span final_tv = mkTcTyVar final_name kind details - ; traceTc "Skolemising" (ppr tv <+> ptext (sLit ":=") <+> ppr final_tv) + ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv) ; writeMetaTyVar tv (mkTyVarTy final_tv) ; return final_tv } diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index 3f4b6adb63..216f25ba8d 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -37,7 +37,6 @@ import TcEvidence import Outputable import Util import SrcLoc -import FastString import DynFlags import PrelNames (monadFailClassName) import qualified GHC.LanguageExtensions as LangExt @@ -94,8 +93,8 @@ tcMatchesFun fun_name matches exp_ty ; return (wrap_gen <.> wrap_fun, group) } where arity = matchGroupArity matches - herald = ptext (sLit "The equation(s) for") - <+> quotes (ppr fun_name) <+> ptext (sLit "have") + herald = text "The equation(s) for" + <+> quotes (ppr fun_name) <+> text "have" match_ctxt = MC { mc_what = FunRhs fun_name, mc_body = tcBody } {- @@ -1059,10 +1058,10 @@ checkArgs fun (MG { mg_alts = L _ (match1:matches) }) | null bad_matches = return () | otherwise - = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+> - ptext (sLit "have different numbers of arguments"), - nest 2 (ppr (getLoc match1)), - nest 2 (ppr (getLoc (head bad_matches)))]) + = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+> + text "have different numbers of arguments" + , nest 2 (ppr (getLoc match1)) + , nest 2 (ppr (getLoc (head bad_matches)))]) where n_args1 = args_in_match match1 bad_matches = [m | m <- matches, args_in_match m /= n_args1] diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index b919e4ed23..d6999f1af2 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -46,7 +46,6 @@ import SrcLoc import VarSet import Util import Outputable -import FastString import Maybes( orElse ) import qualified GHC.LanguageExtensions as LangExt import Control.Monad @@ -217,8 +216,8 @@ addInlinePrags poly_id prags warn_multiple_inlines inl2 inls | otherwise = setSrcSpan loc $ - addWarnTc (hang (ptext (sLit "Multiple INLINE pragmas for") <+> ppr poly_id) - 2 (vcat (ptext (sLit "Ignoring all but the first") + addWarnTc (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) + 2 (vcat (text "Ignoring all but the first" : map pp_inl (inl1:inl2:inls)))) pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) @@ -1027,7 +1026,7 @@ maybeWrapPatCtxt pat tcm thing_inside worth_wrapping (ParPat {}) = False worth_wrapping (AsPat {}) = False worth_wrapping _ = True - msg = hang (ptext (sLit "In the pattern:")) 2 (ppr pat) + msg = hang (text "In the pattern:") 2 (ppr pat) ----------------------------------------------- checkExistentials :: [TyVar] -- existentials @@ -1043,12 +1042,12 @@ checkExistentials _ _ _ = return () existentialLazyPat :: SDoc existentialLazyPat - = hang (ptext (sLit "An existential or GADT data constructor cannot be used")) - 2 (ptext (sLit "inside a lazy (~) pattern")) + = hang (text "An existential or GADT data constructor cannot be used") + 2 (text "inside a lazy (~) pattern") existentialProcPat :: SDoc existentialProcPat - = ptext (sLit "Proc patterns cannot use existential or GADT data constructors") + = text "Proc patterns cannot use existential or GADT data constructors" existentialLetPat :: SDoc existentialLetPat @@ -1058,16 +1057,16 @@ existentialLetPat badFieldCon :: ConLike -> FieldLabelString -> SDoc badFieldCon con field - = hsep [ptext (sLit "Constructor") <+> quotes (ppr con), - ptext (sLit "does not have field"), quotes (ppr field)] + = hsep [text "Constructor" <+> quotes (ppr con), + text "does not have field", quotes (ppr field)] polyPatSig :: TcType -> SDoc polyPatSig sig_ty - = hang (ptext (sLit "Illegal polymorphic type signature in pattern:")) + = hang (text "Illegal polymorphic type signature in pattern:") 2 (ppr sig_ty) lazyUnliftedPatErr :: OutputableBndr name => Pat name -> TcM () lazyUnliftedPatErr pat = failWithTc $ - hang (ptext (sLit "A lazy (~) pattern cannot contain unlifted types:")) + hang (text "A lazy (~) pattern cannot contain unlifted types:") 2 (ppr pat) diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 3b758389c6..c12ca6cba1 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -141,8 +141,8 @@ tcPatSynSig name sig_ty -- should not appear in the result type ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType body_ty) ex_tvs ; unless (null bad_tvs) $ addErr $ - hang (ptext (sLit "The result type") <+> quotes (ppr body_ty)) - 2 (ptext (sLit "mentions existential type variable") <> plural bad_tvs + hang (text "The result type" <+> quotes (ppr body_ty)) + 2 (text "mentions existential type variable" <> plural bad_tvs <+> pprQuotedList bad_tvs) -- Split [Splitting the implicit tyvars in a pattern synonym] @@ -348,15 +348,15 @@ collectPatSynArgInfo details = addPatSynCtxt :: Located Name -> TcM a -> TcM a addPatSynCtxt (L loc name) thing_inside = setSrcSpan loc $ - addErrCtxt (ptext (sLit "In the declaration for pattern synonym") + addErrCtxt (text "In the declaration for pattern synonym" <+> quotes (ppr name)) $ thing_inside wrongNumberOfParmsErr :: Name -> Arity -> Arity -> SDoc wrongNumberOfParmsErr name decl_arity ty_arity - = hang (ptext (sLit "Patten synonym") <+> quotes (ppr name) <+> ptext (sLit "has") - <+> speakNOf decl_arity (ptext (sLit "argument"))) - 2 (ptext (sLit "but its type signature has") <+> speakN ty_arity) + = hang (text "Patten synonym" <+> quotes (ppr name) <+> ptext (sLit "has") + <+> speakNOf decl_arity (text "argument")) + 2 (text "but its type signature has" <+> speakN ty_arity) ------------------------- -- Shared by both tcInferPatSyn and tcCheckPatSyn @@ -593,7 +593,7 @@ tcPatSynBuilderBind sig_fun PSB{ psb_id = L loc name, psb_def = lpat | isNothing mb_match_group -- Can't invert the pattern = setSrcSpan (getLoc lpat) $ failWithTc $ - hang (ptext (sLit "Right-hand side of bidirectional pattern synonym cannot be used as an expression")) + hang (text "Right-hand side of bidirectional pattern synonym cannot be used as an expression") 2 (ppr lpat) | otherwise -- Bidirectional @@ -779,25 +779,25 @@ tcCheckPatSynPat = go asPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a asPatInPatSynErr pat = failWithTc $ - hang (ptext (sLit "Pattern synonym definition cannot contain as-patterns (@):")) + hang (text "Pattern synonym definition cannot contain as-patterns (@):") 2 (ppr pat) thInPatSynErr :: OutputableBndr name => Pat name -> TcM a thInPatSynErr pat = failWithTc $ - hang (ptext (sLit "Pattern synonym definition cannot contain Template Haskell:")) + hang (text "Pattern synonym definition cannot contain Template Haskell:") 2 (ppr pat) nPlusKPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a nPlusKPatInPatSynErr pat = failWithTc $ - hang (ptext (sLit "Pattern synonym definition cannot contain n+k-pattern:")) + hang (text "Pattern synonym definition cannot contain n+k-pattern:") 2 (ppr pat) nonBidirectionalErr :: Outputable name => name -> TcM a nonBidirectionalErr name = failWithTc $ - ptext (sLit "non-bidirectional pattern synonym") - <+> quotes (ppr name) <+> ptext (sLit "used in an expression") + text "non-bidirectional pattern synonym" + <+> quotes (ppr name) <+> text "used in an expression" tcPatToExpr :: [Located Name] -> LPat Name -> Maybe (LHsExpr Name) tcPatToExpr args = go diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index da2aa7416d..3ded08a425 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -169,7 +169,7 @@ tcRnSignature dflags hsc_src case tcg_sig_of tcg_env of { Just sof | hsc_src /= HsigFile -> do - { addErr (ptext (sLit "Illegal -sig-of specified for non hsig")) + { addErr (text "Illegal -sig-of specified for non hsig") ; return tcg_env } | otherwise -> do @@ -189,7 +189,7 @@ tcRnSignature dflags hsc_src { return tcg_env } | HsigFile <- hsc_src -> do - { addErr (ptext (sLit "Missing -sig-of for hsig")) + { addErr (text "Missing -sig-of for hsig") ; failM } | otherwise -> return tcg_env } @@ -385,7 +385,7 @@ tcRnModuleTcRnM hsc_env hsc_src implicitPreludeWarn :: SDoc implicitPreludeWarn - = ptext (sLit "Module `Prelude' implicitly imported") + = text "Module `Prelude' implicitly imported" {- ************************************************************************ @@ -445,7 +445,7 @@ tcRnImports hsc_env import_decls -- interfaces, so that their rules and instance decls will be -- found. But filter out a self hs-boot: these instances -- will be checked when we define them locally. - ; loadModuleInterfaces (ptext (sLit "Loading orphan modules")) + ; loadModuleInterfaces (text "Loading orphan modules") (filter (/= this_mod) (imp_orphs imports)) -- Check type-family consistency @@ -573,7 +573,7 @@ tc_rn_src_decls ds { Nothing -> return () ; ; Just (SpliceDecl (L loc _) _, _) -> setSrcSpan loc $ - addErr (ptext (sLit "Declaration splices are not permitted inside top-level declarations added with addTopDecls")) + addErr (text "Declaration splices are not permitted inside top-level declarations added with addTopDecls") } ; -- Rename TH-generated top-level declarations @@ -691,12 +691,12 @@ tcRnHsBootDecls hsc_src decls badBootDecl :: HscSource -> String -> Located decl -> TcM () badBootDecl hsc_src what (L loc _) = addErrAt loc (char 'A' <+> text what - <+> ptext (sLit "declaration is not (currently) allowed in a") + <+> text "declaration is not (currently) allowed in a" <+> (case hsc_src of - HsBootFile -> ptext (sLit "hs-boot") - HsigFile -> ptext (sLit "hsig") + HsBootFile -> text "hs-boot" + HsigFile -> text "hsig" _ -> panic "badBootDecl: should be an hsig or hs-boot file") - <+> ptext (sLit "file")) + <+> text "file") {- Once we've typechecked the body of the module, we want to compare what @@ -1081,31 +1081,31 @@ emptyRnEnv2 = mkRnEnv2 emptyInScopeSet ---------------- missingBootThing :: Bool -> Name -> String -> SDoc missingBootThing is_boot name what - = quotes (ppr name) <+> ptext (sLit "is exported by the") - <+> (if is_boot then ptext (sLit "hs-boot") else ptext (sLit "hsig")) - <+> ptext (sLit "file, but not") - <+> text what <+> ptext (sLit "the module") + = quotes (ppr name) <+> text "is exported by the" + <+> (if is_boot then text "hs-boot" else text "hsig") + <+> text "file, but not" + <+> text what <+> text "the module" bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc bootMisMatch is_boot extra_info real_thing boot_thing = vcat [ppr real_thing <+> - ptext (sLit "has conflicting definitions in the module"), - ptext (sLit "and its") <+> - (if is_boot then ptext (sLit "hs-boot file") - else ptext (sLit "hsig file")), - ptext (sLit "Main module:") <+> PprTyThing.pprTyThing real_thing, + text "has conflicting definitions in the module", + text "and its" <+> + (if is_boot then text "hs-boot file" + else text "hsig file"), + text "Main module:" <+> PprTyThing.pprTyThing real_thing, (if is_boot - then ptext (sLit "Boot file: ") - else ptext (sLit "Hsig file: ")) + then text "Boot file: " + else text "Hsig file: ") <+> PprTyThing.pprTyThing boot_thing, extra_info] instMisMatch :: Bool -> ClsInst -> SDoc instMisMatch is_boot inst = hang (ppr inst) - 2 (ptext (sLit "is defined in the") <+> - (if is_boot then ptext (sLit "hs-boot") else ptext (sLit "hsig")) - <+> ptext (sLit "file, but not in the module itself")) + 2 (text "is defined in the" <+> + (if is_boot then text "hs-boot" else text "hsig") + <+> text "file, but not in the module itself") {- ************************************************************************ @@ -1511,9 +1511,9 @@ check_main dflags tcg_env explicit_mod_hdr -- In other modes, fail altogether, so that we don't go on -- and complain a second time when processing the export list. - mainCtxt = ptext (sLit "When checking the type of the") <+> pp_main_fn - noMainMsg = ptext (sLit "The") <+> pp_main_fn - <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod) + mainCtxt = text "When checking the type of the" <+> pp_main_fn + noMainMsg = text "The" <+> pp_main_fn + <+> text "is not defined in module" <+> quotes (ppr main_mod) pp_main_fn = ppMainFn main_fn -- | Get the unqualified name of the function to use as the \"main\" for the main module. @@ -1532,15 +1532,15 @@ checkMainExported tcg_env do { dflags <- getDynFlags ; let main_mod = mainModIs dflags ; checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $ - ptext (sLit "The") <+> ppMainFn (nameRdrName main_name) <+> - ptext (sLit "is not exported by module") <+> quotes (ppr main_mod) } + text "The" <+> ppMainFn (nameRdrName main_name) <+> + text "is not exported by module" <+> quotes (ppr main_mod) } ppMainFn :: RdrName -> SDoc ppMainFn main_fn | rdrNameOcc main_fn == mainOcc - = ptext (sLit "IO action") <+> quotes (ppr main_fn) + = text "IO action" <+> quotes (ppr main_fn) | otherwise - = ptext (sLit "main IO action") <+> quotes (ppr main_fn) + = text "main IO action" <+> quotes (ppr main_fn) mainOcc :: OccName mainOcc = mkVarOccFS (fsLit "main") @@ -1720,7 +1720,7 @@ tcRnStmt hsc_env rdr_stmt return (global_ids, zonked_expr, fix_env) } where - bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"), + bad_unboxed id = addErr (sep [text "GHCi can't bind a variable of unlifted type:", nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) {- @@ -2113,7 +2113,7 @@ externaliseAndTidyId this_mod id getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface) getModuleInterface hsc_env mod = runTcInteractive hsc_env $ - loadModuleInterface (ptext (sLit "getModuleInterface")) mod + loadModuleInterface (text "getModuleInterface") mod tcRnLookupRdrName :: HscEnv -> Located RdrName -> IO (Messages, Maybe [Name]) @@ -2127,7 +2127,7 @@ tcRnLookupRdrName hsc_env (L loc rdr_name) let rdr_names = dataTcOccs rdr_name ; names_s <- mapM lookupInfoOccRn rdr_names ; let names = concat names_s - ; when (null names) (addErrTc (ptext (sLit "Not in scope:") <+> quotes (ppr rdr_name))) + ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name))) ; return names } #endif @@ -2213,7 +2213,7 @@ loadUnqualIfaces hsc_env ictxt , nameIsFromExternalPackage this_pkg name , isTcOcc (nameOccName name) -- Types and classes only , unQualOK gre ] -- In scope unqualified - doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified") + doc = text "Need interface for module whose export(s) are in scope unqualified" {- ****************************************************************************** @@ -2394,9 +2394,9 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , ppr_fam_insts fam_insts , vcat (map ppr rules) , vcat (map ppr vects) - , ptext (sLit "Dependent modules:") <+> + , text "Dependent modules:" <+> ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) - , ptext (sLit "Dependent packages:") <+> + , text "Dependent packages:" <+> ppr (sortBy stableUnitIdCmp $ imp_dep_pkgs imports)] where -- The two uses of sortBy are just to reduce unnecessary -- wobbling in testsuite output diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index f55f5dd548..b0b1e3dcfe 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -953,9 +953,9 @@ checkTH e what = failTH e what -- Raise an error in a stage-1 compiler failTH :: Outputable a => a -> String -> TcRn x failTH e what -- Raise an error in a stage-1 compiler = failWithTc (vcat [ hang (char 'A' <+> text what - <+> ptext (sLit "requires GHC with interpreter support:")) + <+> text "requires GHC with interpreter support:") 2 (ppr e) - , ptext (sLit "Perhaps you are using a stage-1 compiler?") ]) + , text "Perhaps you are using a stage-1 compiler?" ]) {- ************************************************************************ @@ -1353,7 +1353,7 @@ recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) T keepAlive :: Name -> TcRn () -- Record the name in the keep-alive set keepAlive name = do { env <- getGblEnv - ; traceRn (ptext (sLit "keep alive") <+> ppr name) + ; traceRn (text "keep alive" <+> ppr name) ; updTcRef (tcg_keep env) (`extendNameSet` name) } getStage :: TcM ThStage @@ -1466,7 +1466,7 @@ initIfaceTc iface do_this } where mod = mi_module iface - doc = ptext (sLit "The interface for") <+> quotes (ppr mod) + doc = text "The interface for" <+> quotes (ppr mod) initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a initIfaceLcl mod loc_doc thing_inside diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 6330c71c88..60abfca12e 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -925,20 +925,20 @@ instance Outputable PromotionErr where pprTcTyThingCategory :: TcTyThing -> SDoc pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing -pprTcTyThingCategory (ATyVar {}) = ptext (sLit "Type variable") -pprTcTyThingCategory (ATcId {}) = ptext (sLit "Local identifier") -pprTcTyThingCategory (ATcTyCon {}) = ptext (sLit "Local tycon") +pprTcTyThingCategory (ATyVar {}) = text "Type variable" +pprTcTyThingCategory (ATcId {}) = text "Local identifier" +pprTcTyThingCategory (ATcTyCon {}) = text "Local tycon" pprTcTyThingCategory (APromotionErr pe) = pprPECategory pe pprPECategory :: PromotionErr -> SDoc -pprPECategory ClassPE = ptext (sLit "Class") -pprPECategory TyConPE = ptext (sLit "Type constructor") -pprPECategory PatSynPE = ptext (sLit "Pattern synonym") -pprPECategory FamDataConPE = ptext (sLit "Data constructor") -pprPECategory RecDataConPE = ptext (sLit "Data constructor") -pprPECategory NoDataKinds = ptext (sLit "Data constructor") -pprPECategory NoTypeInTypeTC = ptext (sLit "Type constructor") -pprPECategory NoTypeInTypeDC = ptext (sLit "Data constructor") +pprPECategory ClassPE = text "Class" +pprPECategory TyConPE = text "Type constructor" +pprPECategory PatSynPE = text "Pattern synonym" +pprPECategory FamDataConPE = text "Data constructor" +pprPECategory RecDataConPE = text "Data constructor" +pprPECategory NoDataKinds = text "Data constructor" +pprPECategory NoTypeInTypeTC = text "Type constructor" +pprPECategory NoTypeInTypeDC = text "Data constructor" {- Note [Bindings with closed types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1123,10 +1123,10 @@ data WhereFrom -- See Note [Care with plugin imports] in LoadIface instance Outputable WhereFrom where - ppr (ImportByUser is_boot) | is_boot = ptext (sLit "{- SOURCE -}") + ppr (ImportByUser is_boot) | is_boot = text "{- SOURCE -}" | otherwise = empty - ppr ImportBySystem = ptext (sLit "{- SYSTEM -}") - ppr ImportByPlugin = ptext (sLit "{- PLUGIN -}") + ppr ImportBySystem = text "{- SYSTEM -}" + ppr ImportByPlugin = text "{- PLUGIN -}" {- ********************************************************************* @@ -1226,8 +1226,8 @@ instance Outputable TcIdSigInfo where , ppr (map fst tyvars) ] instance Outputable TcIdSigBndr where - ppr (CompleteSig f) = ptext (sLit "CompleteSig") <+> ppr f - ppr (PartialSig { sig_name = n }) = ptext (sLit "PartialSig") <+> ppr n + ppr (CompleteSig f) = text "CompleteSig" <+> ppr f + ppr (PartialSig { sig_name = n }) = text "PartialSig" <+> ppr n instance Outputable TcPatSynInfo where ppr (TPSI{ patsig_name = name}) = ppr name @@ -1911,10 +1911,10 @@ trulyInsoluble _tc_lvl insol instance Outputable WantedConstraints where ppr (WC {wc_simple = s, wc_impl = i, wc_insol = n}) - = ptext (sLit "WC") <+> braces (vcat - [ ppr_bag (ptext (sLit "wc_simple")) s - , ppr_bag (ptext (sLit "wc_insol")) n - , ppr_bag (ptext (sLit "wc_impl")) i ]) + = text "WC" <+> braces (vcat + [ ppr_bag (text "wc_simple") s + , ppr_bag (text "wc_insol") n + , ppr_bag (text "wc_impl") i ]) ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc ppr_bag doc bag @@ -1977,23 +1977,23 @@ instance Outputable Implication where , ic_given = given, ic_no_eqs = no_eqs , ic_wanted = wanted, ic_status = status , ic_binds = binds, ic_info = info }) - = hang (ptext (sLit "Implic") <+> lbrace) - 2 (sep [ ptext (sLit "TcLevel =") <+> ppr tclvl - , ptext (sLit "Skolems =") <+> pprTvBndrs skols - , ptext (sLit "No-eqs =") <+> ppr no_eqs - , ptext (sLit "Status =") <+> ppr status - , hang (ptext (sLit "Given =")) 2 (pprEvVars given) - , hang (ptext (sLit "Wanted =")) 2 (ppr wanted) - , ptext (sLit "Binds =") <+> ppr binds + = hang (text "Implic" <+> lbrace) + 2 (sep [ text "TcLevel =" <+> ppr tclvl + , text "Skolems =" <+> pprTvBndrs skols + , text "No-eqs =" <+> ppr no_eqs + , text "Status =" <+> ppr status + , hang (text "Given =") 2 (pprEvVars given) + , hang (text "Wanted =") 2 (ppr wanted) + , text "Binds =" <+> ppr binds , pprSkolInfo info ] <+> rbrace) instance Outputable ImplicStatus where - ppr IC_Insoluble = ptext (sLit "Insoluble") - ppr IC_Unsolved = ptext (sLit "Unsolved") + ppr IC_Insoluble = text "Insoluble" + ppr IC_Unsolved = text "Unsolved" ppr (IC_Solved { ics_need = vs, ics_dead = dead }) - = ptext (sLit "Solved") - <+> (braces $ vcat [ ptext (sLit "Dead givens =") <+> ppr dead - , ptext (sLit "Needed =") <+> ppr vs ]) + = text "Solved" + <+> (braces $ vcat [ text "Dead givens =" <+> ppr dead + , text "Needed =" <+> ppr vs ]) {- Note [Needed evidence variables] @@ -2182,9 +2182,9 @@ instance Outputable TcEvDest where instance Outputable CtEvidence where ppr fl = case fl of - CtGiven {} -> ptext (sLit "[G]") <+> ppr (ctev_evar fl) <+> ppr_pty - CtWanted {} -> ptext (sLit "[W]") <+> ppr (ctev_dest fl) <+> ppr_pty - CtDerived {} -> ptext (sLit "[D]") <+> text "_" <+> ppr_pty + CtGiven {} -> text "[G]" <+> ppr (ctev_evar fl) <+> ppr_pty + CtWanted {} -> text "[W]" <+> ppr (ctev_dest fl) <+> ppr_pty + CtDerived {} -> text "[D]" <+> text "_" <+> ppr_pty where ppr_pty = dcolon <+> ppr (ctEvPred fl) isWanted :: CtEvidence -> Bool @@ -2561,28 +2561,28 @@ instance Outputable SkolemInfo where pprSkolInfo :: SkolemInfo -> SDoc -- Complete the sentence "is a rigid type variable bound by..." pprSkolInfo (SigSkol ctxt ty) = pprSigSkolInfo ctxt ty -pprSkolInfo (IPSkol ips) = ptext (sLit "the implicit-parameter binding") <> plural ips <+> ptext (sLit "for") +pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural ips <+> text "for" <+> pprWithCommas ppr ips -pprSkolInfo (ClsSkol cls) = ptext (sLit "the class declaration for") <+> quotes (ppr cls) -pprSkolInfo (DerivSkol pred) = ptext (sLit "the deriving clause for") <+> quotes (ppr pred) -pprSkolInfo InstSkol = ptext (sLit "the instance declaration") -pprSkolInfo (InstSC n) = ptext (sLit "the instance declaration") <> ifPprDebug (parens (ppr n)) -pprSkolInfo DataSkol = ptext (sLit "a data type declaration") -pprSkolInfo FamInstSkol = ptext (sLit "a family instance declaration") -pprSkolInfo BracketSkol = ptext (sLit "a Template Haskell bracket") -pprSkolInfo (RuleSkol name) = ptext (sLit "the RULE") <+> pprRuleName name -pprSkolInfo ArrowSkol = ptext (sLit "an arrow form") +pprSkolInfo (ClsSkol cls) = text "the class declaration for" <+> quotes (ppr cls) +pprSkolInfo (DerivSkol pred) = text "the deriving clause for" <+> quotes (ppr pred) +pprSkolInfo InstSkol = text "the instance declaration" +pprSkolInfo (InstSC n) = text "the instance declaration" <> ifPprDebug (parens (ppr n)) +pprSkolInfo DataSkol = text "a data type declaration" +pprSkolInfo FamInstSkol = text "a family instance declaration" +pprSkolInfo BracketSkol = text "a Template Haskell bracket" +pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name +pprSkolInfo ArrowSkol = text "an arrow form" pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl - , ptext (sLit "in") <+> pprMatchContext mc ] -pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of") + , text "in" <+> pprMatchContext mc ] +pprSkolInfo (InferSkol ids) = sep [ text "the inferred type of" , vcat [ ppr name <+> dcolon <+> ppr ty | (name,ty) <- ids ]] -pprSkolInfo (UnifyForAllSkol ty) = ptext (sLit "the type") <+> ppr ty +pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty -- UnkSkol -- For type variables the others are dealt with by pprSkolTvBinding. -- For Insts, these cases should not happen -pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol") +pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) text "UnkSkol" pprSigSkolInfo :: UserTypeCtxt -> Type -> SDoc pprSigSkolInfo ctxt ty @@ -2591,12 +2591,12 @@ pprSigSkolInfo ctxt ty _ -> vcat [ pprUserTypeCtxt ctxt <> colon , nest 2 (ppr ty) ] where - pp_sig f = vcat [ ptext (sLit "the type signature for:") + pp_sig f = vcat [ text "the type signature for:" , nest 2 (pprPrefixOcc f <+> dcolon <+> ppr ty) ] pprPatSkolInfo :: ConLike -> SDoc pprPatSkolInfo (RealDataCon dc) - = sep [ ptext (sLit "a pattern with constructor:") + = sep [ text "a pattern with constructor:" , nest 2 $ ppr dc <+> dcolon <+> pprType (dataConUserType dc) <> comma ] -- pprType prints forall's regardless of -fprint-explict-foralls @@ -2604,7 +2604,7 @@ pprPatSkolInfo (RealDataCon dc) -- type variable 't' is bound by ... pprPatSkolInfo (PatSynCon ps) - = sep [ ptext (sLit "a pattern with pattern synonym:") + = sep [ text "a pattern with pattern synonym:" , nest 2 $ ppr ps <+> dcolon <+> pprType (patSynType ps) <> comma ] @@ -2737,7 +2737,7 @@ instance Outputable ErrorThing where ppr (ErrorThing thing _ _) = ppr thing ctoHerald :: SDoc -ctoHerald = ptext (sLit "arising from") +ctoHerald = text "arising from" -- | Extract a suitable CtOrigin from a HsExpr exprCtOrigin :: HsExpr Name -> CtOrigin @@ -2825,38 +2825,38 @@ pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk pprCtOrigin (SpecPragOrigin ctxt) = case ctxt of - FunSigCtxt n _ -> ptext (sLit "a SPECIALISE pragma for") <+> quotes (ppr n) - SpecInstCtxt -> ptext (sLit "a SPECIALISE INSTANCE pragma") - _ -> ptext (sLit "a SPECIALISE pragma") -- Never happens I think + FunSigCtxt n _ -> text "a SPECIALISE pragma for" <+> quotes (ppr n) + SpecInstCtxt -> text "a SPECIALISE INSTANCE pragma" + _ -> text "a SPECIALISE pragma" -- Never happens I think pprCtOrigin (FunDepOrigin1 pred1 loc1 pred2 loc2) - = hang (ctoHerald <+> ptext (sLit "a functional dependency between constraints:")) + = hang (ctoHerald <+> text "a functional dependency between constraints:") 2 (vcat [ hang (quotes (ppr pred1)) 2 (pprCtLoc loc1) , hang (quotes (ppr pred2)) 2 (pprCtLoc loc2) ]) pprCtOrigin (FunDepOrigin2 pred1 orig1 pred2 loc2) - = hang (ctoHerald <+> ptext (sLit "a functional dependency between:")) - 2 (vcat [ hang (ptext (sLit "constraint") <+> quotes (ppr pred1)) + = hang (ctoHerald <+> text "a functional dependency between:") + 2 (vcat [ hang (text "constraint" <+> quotes (ppr pred1)) 2 (pprCtOrigin orig1 ) - , hang (ptext (sLit "instance") <+> quotes (ppr pred2)) - 2 (ptext (sLit "at") <+> ppr loc2) ]) + , hang (text "instance" <+> quotes (ppr pred2)) + 2 (text "at" <+> ppr loc2) ]) pprCtOrigin (KindEqOrigin t1 t2 _ _) - = hang (ctoHerald <+> ptext (sLit "a kind equality arising from")) + = hang (ctoHerald <+> text "a kind equality arising from") 2 (sep [ppr t1, char '~', ppr t2]) pprCtOrigin (UnboundOccurrenceOf name) - = ctoHerald <+> ptext (sLit "an undeclared identifier") <+> quotes (ppr name) + = ctoHerald <+> text "an undeclared identifier" <+> quotes (ppr name) pprCtOrigin (DerivOriginDC dc n) - = hang (ctoHerald <+> ptext (sLit "the") <+> speakNth n - <+> ptext (sLit "field of") <+> quotes (ppr dc)) - 2 (parens (ptext (sLit "type") <+> quotes (ppr ty))) + = hang (ctoHerald <+> text "the" <+> speakNth n + <+> text "field of" <+> quotes (ppr dc)) + 2 (parens (text "type" <+> quotes (ppr ty))) where ty = dataConOrigArgTys dc !! (n-1) pprCtOrigin (DerivOriginCoerce meth ty1 ty2) - = hang (ctoHerald <+> ptext (sLit "the coercion of the method") <+> quotes (ppr meth)) + = hang (ctoHerald <+> text "the coercion of the method" <+> quotes (ppr meth)) 2 (sep [ text "from type" <+> quotes (ppr ty1) , nest 2 $ text "to type" <+> quotes (ppr ty2) ]) @@ -2888,37 +2888,37 @@ pprCtOrigin simple_origin -- | Short one-liners pprCtO :: CtOrigin -> SDoc -pprCtO (OccurrenceOf name) = hsep [ptext (sLit "a use of"), quotes (ppr name)] -pprCtO (OccurrenceOfRecSel name) = hsep [ptext (sLit "a use of"), quotes (ppr name)] -pprCtO AppOrigin = ptext (sLit "an application") -pprCtO (IPOccOrigin name) = hsep [ptext (sLit "a use of implicit parameter"), quotes (ppr name)] -pprCtO (OverLabelOrigin l) = hsep [ptext (sLit "the overloaded label") +pprCtO (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)] +pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)] +pprCtO AppOrigin = text "an application" +pprCtO (IPOccOrigin name) = hsep [text "a use of implicit parameter", quotes (ppr name)] +pprCtO (OverLabelOrigin l) = hsep [text "the overloaded label" ,quotes (char '#' <> ppr l)] -pprCtO RecordUpdOrigin = ptext (sLit "a record update") -pprCtO ExprSigOrigin = ptext (sLit "an expression type signature") -pprCtO PatSigOrigin = ptext (sLit "a pattern type signature") -pprCtO PatOrigin = ptext (sLit "a pattern") -pprCtO ViewPatOrigin = ptext (sLit "a view pattern") -pprCtO IfOrigin = ptext (sLit "an if expression") -pprCtO (LiteralOrigin lit) = hsep [ptext (sLit "the literal"), quotes (ppr lit)] -pprCtO (ArithSeqOrigin seq) = hsep [ptext (sLit "the arithmetic sequence"), quotes (ppr seq)] -pprCtO (PArrSeqOrigin seq) = hsep [ptext (sLit "the parallel array sequence"), quotes (ppr seq)] -pprCtO SectionOrigin = ptext (sLit "an operator section") -pprCtO TupleOrigin = ptext (sLit "a tuple") -pprCtO NegateOrigin = ptext (sLit "a use of syntactic negation") -pprCtO (ScOrigin n) = ptext (sLit "the superclasses of an instance declaration") +pprCtO RecordUpdOrigin = text "a record update" +pprCtO ExprSigOrigin = text "an expression type signature" +pprCtO PatSigOrigin = text "a pattern type signature" +pprCtO PatOrigin = text "a pattern" +pprCtO ViewPatOrigin = text "a view pattern" +pprCtO IfOrigin = text "an if expression" +pprCtO (LiteralOrigin lit) = hsep [text "the literal", quotes (ppr lit)] +pprCtO (ArithSeqOrigin seq) = hsep [text "the arithmetic sequence", quotes (ppr seq)] +pprCtO (PArrSeqOrigin seq) = hsep [text "the parallel array sequence", quotes (ppr seq)] +pprCtO SectionOrigin = text "an operator section" +pprCtO TupleOrigin = text "a tuple" +pprCtO NegateOrigin = text "a use of syntactic negation" +pprCtO (ScOrigin n) = text "the superclasses of an instance declaration" <> ifPprDebug (parens (ppr n)) -pprCtO DerivOrigin = ptext (sLit "the 'deriving' clause of a data type declaration") -pprCtO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration") -pprCtO DefaultOrigin = ptext (sLit "a 'default' declaration") -pprCtO DoOrigin = ptext (sLit "a do statement") +pprCtO DerivOrigin = text "the 'deriving' clause of a data type declaration" +pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration" +pprCtO DefaultOrigin = text "a 'default' declaration" +pprCtO DoOrigin = text "a do statement" pprCtO MCompOrigin = text "a statement in a monad comprehension" -pprCtO ProcOrigin = ptext (sLit "a proc expression") -pprCtO (TypeEqOrigin t1 t2 _)= ptext (sLit "a type equality") <+> sep [ppr t1, char '~', ppr t2] -pprCtO AnnOrigin = ptext (sLit "an annotation") -pprCtO HoleOrigin = ptext (sLit "a use of") <+> quotes (ptext $ sLit "_") -pprCtO ListOrigin = ptext (sLit "an overloaded list") -pprCtO StaticOrigin = ptext (sLit "a static form") +pprCtO ProcOrigin = text "a proc expression" +pprCtO (TypeEqOrigin t1 t2 _)= text "a type equality" <+> sep [ppr t1, char '~', ppr t2] +pprCtO AnnOrigin = text "an annotation" +pprCtO HoleOrigin = text "a use of" <+> quotes (text "_") +pprCtO ListOrigin = text "an overloaded list" +pprCtO StaticOrigin = text "a static form" pprCtO _ = panic "pprCtOrigin" {- diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs index d90b9a7305..fe6561c306 100644 --- a/compiler/typecheck/TcRules.hs +++ b/compiler/typecheck/TcRules.hs @@ -154,7 +154,7 @@ tcRuleBndrs (L _ (RuleBndrSig (L _ name) rn_ty) : rule_bndrs) ; return (tvs ++ id : vars) } ruleCtxt :: FastString -> SDoc -ruleCtxt name = ptext (sLit "When checking the transformation rule") <+> +ruleCtxt name = text "When checking the transformation rule" <+> doubleQuotes (ftext name) @@ -325,7 +325,7 @@ simplifyRule name lhs_wanted rhs_wanted bagToList zonked_lhs_simples ; traceTc "simplifyRule" $ - vcat [ ptext (sLit "LHS of rule") <+> doubleQuotes (ftext name) + vcat [ text "LHS of rule" <+> doubleQuotes (ftext name) , text "lhs_wantd" <+> ppr lhs_wanted , text "rhs_wantd" <+> ppr rhs_wanted , text "zonked_lhs_simples" <+> ppr zonked_lhs_simples diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 6d309583cd..0214f135da 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -143,7 +143,6 @@ import VarSet import Outputable import Bag import UniqSupply -import FastString import Util import TcRnTypes @@ -317,15 +316,15 @@ instance Outputable WorkList where , wl_rest = rest, wl_implics = implics, wl_deriv = ders }) = text "WL" <+> (braces $ vcat [ ppUnless (null eqs) $ - ptext (sLit "Eqs =") <+> vcat (map ppr eqs) + text "Eqs =" <+> vcat (map ppr eqs) , ppUnless (null feqs) $ - ptext (sLit "Funeqs =") <+> vcat (map ppr feqs) + text "Funeqs =" <+> vcat (map ppr feqs) , ppUnless (null rest) $ - ptext (sLit "Non-eqs =") <+> vcat (map ppr rest) + text "Non-eqs =" <+> vcat (map ppr rest) , ppUnless (null ders) $ - ptext (sLit "Derived =") <+> vcat (map ppr ders) + text "Derived =" <+> vcat (map ppr ders) , ppUnless (isEmptyBag implics) $ - ptext (sLit "Implics =") <+> vcat (map ppr (bagToList implics)) + text "Implics =" <+> vcat (map ppr (bagToList implics)) ]) @@ -1060,16 +1059,16 @@ instance Outputable InertCans where , inert_insols = insols, inert_count = count }) = braces $ vcat [ ppUnless (isEmptyVarEnv eqs) $ - ptext (sLit "Equalities:") + text "Equalities:" <+> pprCts (foldVarEnv (\eqs rest -> listToBag eqs `andCts` rest) emptyCts eqs) , ppUnless (isEmptyTcAppMap funeqs) $ - ptext (sLit "Type-function equalities =") <+> pprCts (funEqsToBag funeqs) + text "Type-function equalities =" <+> pprCts (funEqsToBag funeqs) , ppUnless (isEmptyTcAppMap dicts) $ - ptext (sLit "Dictionaries =") <+> pprCts (dictsToBag dicts) + text "Dictionaries =" <+> pprCts (dictsToBag dicts) , ppUnless (isEmptyTcAppMap safehask) $ - ptext (sLit "Safe Haskell unsafe overlap =") <+> pprCts (dictsToBag safehask) + text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask) , ppUnless (isEmptyCts irreds) $ - ptext (sLit "Irreds =") <+> pprCts irreds + text "Irreds =" <+> pprCts irreds , ppUnless (isEmptyCts insols) $ text "Insolubles =" <+> pprCts insols , ppUnless (isEmptyVarEnv model) $ @@ -1185,7 +1184,7 @@ addInertEq ct@(CTyEqCan { cc_tyvar = tv }) ; unless (isEmptyWorkList kicked_out) $ do { updWorkListTcS (appendWorkList kicked_out) ; csTraceTcS $ - hang (ptext (sLit "Kick out, tv =") <+> ppr tv) + hang (text "Kick out, tv =" <+> ppr tv) 2 (vcat [ text "n-kicked =" <+> int (workListSize kicked_out) , ppr kicked_out ]) } @@ -1237,8 +1236,8 @@ emitDerivedShadows IC { inert_eqs = tv_eqs = return () | otherwise = do { traceTcS "Emit derived shadows:" $ - vcat [ ptext (sLit "tyvar =") <+> ppr new_tv - , ptext (sLit "shadows =") <+> vcat (map ppr shadows) ] + vcat [ text "tyvar =" <+> ppr new_tv + , text "shadows =" <+> vcat (map ppr shadows) ] ; emitWork shadows } where shadows = foldDicts get_ct dicts $ @@ -1475,7 +1474,7 @@ kickOutAfterUnification new_tv ; unless (isEmptyWorkList kicked_out) $ csTraceTcS $ - hang (ptext (sLit "Kick out (unify), tv =") <+> ppr new_tv) + hang (text "Kick out (unify), tv =" <+> ppr new_tv) 2 (vcat [ text "n-kicked =" <+> int (workListSize kicked_out) , text "kicked_out =" <+> ppr kicked_out , text "Residual inerts =" <+> ppr ics2 ]) @@ -2357,7 +2356,7 @@ traceFireTcS ev doc = TcS $ \env -> csTraceTcM 1 $ do { n <- TcM.readTcRef (tcs_count env) ; tclvl <- TcM.getTcLevel - ; return (hang (int n <> brackets (ptext (sLit "U:") <> ppr tclvl + ; return (hang (int n <> brackets (text "U:" <> ppr tclvl <> ppr (ctLocDepth (ctEvLoc ev))) <+> doc <> colon) 4 (ppr ev)) } @@ -2416,7 +2415,7 @@ runTcSWithEvBinds solve_deriveds ev_binds_var tcs ; count <- TcM.readTcRef step_count ; when (count > 0) $ - csTraceTcM 0 $ return (ptext (sLit "Constraint solver steps =") <+> int count) + csTraceTcM 0 $ return (text "Constraint solver steps =" <+> int count) #ifdef DEBUG ; whenIsJust ev_binds_var $ \ebv -> @@ -2702,7 +2701,7 @@ checkWellStagedDFun pred dfun_id loc do { use_stage <- TcM.getStage ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) } where - pp_thing = ptext (sLit "instance for") <+> quotes (ppr pred) + pp_thing = text "instance for" <+> quotes (ppr pred) bind_lvl = TcM.topIdLvl dfun_id pprEq :: TcType -> TcType -> SDoc diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index 4d93912bad..c428ce9104 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -44,7 +44,6 @@ import Var import VarSet import BasicTypes ( IntWithInf, intGtLimit ) import ErrUtils ( emptyMessages ) -import FastString import qualified GHC.LanguageExtensions as LangExt import Control.Monad ( when, unless ) @@ -500,11 +499,11 @@ simplifyInfer rhs_tclvl apply_mr sigs name_taus wanteds | otherwise = do { traceTc "simplifyInfer {" $ vcat - [ ptext (sLit "sigs =") <+> ppr sigs - , ptext (sLit "binds =") <+> ppr name_taus - , ptext (sLit "rhs_tclvl =") <+> ppr rhs_tclvl - , ptext (sLit "apply_mr =") <+> ppr apply_mr - , ptext (sLit "(unzonked) wanted =") <+> ppr wanteds + [ text "sigs =" <+> ppr sigs + , text "binds =" <+> ppr name_taus + , text "rhs_tclvl =" <+> ppr rhs_tclvl + , text "apply_mr =" <+> ppr apply_mr + , text "(unzonked) wanted =" <+> ppr wanteds ] -- First do full-blown solving @@ -630,13 +629,13 @@ simplifyInfer rhs_tclvl apply_mr sigs name_taus wanteds -- All done! ; traceTc "} simplifyInfer/produced residual implication for quantification" $ - vcat [ ptext (sLit "quant_pred_candidates =") <+> ppr quant_pred_candidates - , ptext (sLit "zonked_taus") <+> ppr zonked_taus - , ptext (sLit "zonked_tau_tvs=") <+> ppr zonked_tau_tvs - , ptext (sLit "promote_tvs=") <+> ppr promote_tvs - , ptext (sLit "bound_theta =") <+> ppr bound_theta - , ptext (sLit "qtvs =") <+> ppr qtvs - , ptext (sLit "implic =") <+> ppr implic ] + vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates + , text "zonked_taus" <+> ppr zonked_taus + , text "zonked_tau_tvs=" <+> ppr zonked_tau_tvs + , text "promote_tvs=" <+> ppr promote_tvs + , text "bound_theta =" <+> ppr bound_theta + , text "qtvs =" <+> ppr qtvs + , text "implic =" <+> ppr implic ] ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var ) } @@ -722,10 +721,10 @@ decideQuantification apply_mr sigs name_taus constraints ; let mr_bites = constrained_tvs `intersectsVarSet` zonked_tkvs ; warnTc (warn_mono && mr_bites) $ hang (text "The Monomorphism Restriction applies to the binding" - <> plural bndrs <+> ptext (sLit "for") <+> pp_bndrs) + <> plural bndrs <+> text "for" <+> pp_bndrs) 2 (text "Consider giving a type signature for" <+> if isSingleton bndrs then pp_bndrs - else ptext (sLit "these binders")) + else text "these binders") -- All done ; traceTc "decideQuantification 1" (vcat [ppr constraints, ppr gbl_tvs, ppr mono_tvs @@ -1018,14 +1017,14 @@ simpl_loop n limit floated_eqs no_new_scs = return wc -- Done! | n `intGtLimit` limit - = do { warnTcS (hang (ptext (sLit "solveWanteds: too many iterations") - <+> parens (ptext (sLit "limit =") <+> ppr limit)) - 2 (vcat [ ptext (sLit "Unsolved:") <+> ppr wc + = do { warnTcS (hang (text "solveWanteds: too many iterations" + <+> parens (text "limit =" <+> ppr limit)) + 2 (vcat [ text "Unsolved:" <+> ppr wc , ppUnless (isEmptyBag floated_eqs) $ - ptext (sLit "Floated equalities:") <+> ppr floated_eqs + text "Floated equalities:" <+> ppr floated_eqs , ppUnless no_new_scs $ - ptext (sLit "New superclasses found") - , ptext (sLit "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit") + text "New superclasses found" + , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" ])) ; return wc } diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index ab2e30cb31..fe13226c60 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -45,7 +45,6 @@ import TcType import Outputable import TcExpr import SrcLoc -import FastString import THNames import TcUnify import TcEnv @@ -103,6 +102,7 @@ import Unique import VarSet ( isEmptyVarSet, filterVarSet ) import Data.List ( find ) import Data.Maybe +import FastString import BasicTypes hiding( SuccessFlag(..) ) import Maybes( MaybeErr(..) ) import DynFlags @@ -226,7 +226,7 @@ tcTExpTy tau quotationCtxtDoc :: HsBracket Name -> SDoc quotationCtxtDoc br_body - = hang (ptext (sLit "In the Template Haskell quotation")) + = hang (text "In the Template Haskell quotation") 2 (ppr br_body) @@ -497,14 +497,14 @@ tcTopSplice expr res_ty spliceCtxtDoc :: HsSplice Name -> SDoc spliceCtxtDoc splice - = hang (ptext (sLit "In the Template Haskell splice")) + = hang (text "In the Template Haskell splice") 2 (pprSplice splice) spliceResultDoc :: LHsExpr Name -> SDoc spliceResultDoc expr - = sep [ ptext (sLit "In the result of the splice:") + = sep [ text "In the result of the splice:" , nest 2 (char '$' <> pprParendExpr expr) - , ptext (sLit "To see what the splice expanded to, use -ddump-splices")] + , text "To see what the splice expanded to, use -ddump-splices"] ------------------- tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr Id) -> TcM (LHsExpr Id) @@ -870,7 +870,7 @@ instance TH.Quasi TcM where bindName name = addErr $ - hang (ptext (sLit "The binder") <+> quotes (ppr name) <+> ptext (sLit "is not a NameU.")) + hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU.")) 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") qAddModFinalizer fin = do @@ -1069,7 +1069,7 @@ getAnnotationsByTypeRep th_name tyrep reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec] reifyInstances th_nm th_tys - = addErrCtxt (ptext (sLit "In the argument of reifyInstances:") + = addErrCtxt (text "In the argument of reifyInstances:" <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $ do { loc <- getSrcSpanM ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys) @@ -1104,8 +1104,8 @@ reifyInstances th_nm th_tys ; let matches = lookupFamInstEnv inst_envs tc tys ; traceTc "reifyInstances2" (ppr matches) ; reifyFamilyInstances tc (map fim_instance matches) } - _ -> bale_out (hang (ptext (sLit "reifyInstances:") <+> quotes (ppr ty)) - 2 (ptext (sLit "is not a class constraint or type family application"))) } + _ -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty)) + 2 (text "is not a class constraint or type family application")) } where doc = ClassInstanceCtx bale_out msg = failWithTc msg @@ -1219,12 +1219,12 @@ tcLookupTh name notInScope :: TH.Name -> SDoc notInScope th_name = quotes (text (TH.pprint th_name)) <+> - ptext (sLit "is not in scope at a reify") + text "is not in scope at a reify" -- Ugh! Rather an indirect way to display the name notInEnv :: Name -> SDoc notInEnv name = quotes (ppr name) <+> - ptext (sLit "is not in the type environment at a reify") + text "is not in the type environment at a reify" ------------------------------ reifyRoles :: TH.Name -> TcM [TH.Role] @@ -1232,7 +1232,7 @@ reifyRoles th_name = do { thing <- getThing th_name ; case thing of AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) - _ -> failWithTc (ptext (sLit "No roles associated with") <+> (ppr thing)) + _ -> failWithTc (text "No roles associated with" <+> (ppr thing)) } where reify_role Nominal = TH.NominalR @@ -1869,7 +1869,7 @@ reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do return $ TH.ModuleInfo usages reifyFromIface reifMod = do - iface <- loadInterfaceForModule (ptext (sLit "reifying module from TH for") <+> ppr reifMod) reifMod + iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod let usages = [modToTHMod m | usage <- mi_usages iface, Just m <- [usageToModule (moduleUnitId reifMod) usage] ] return $ TH.ModuleInfo usages @@ -1884,8 +1884,8 @@ mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys noTH :: LitString -> SDoc -> TcM a -noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+> - ptext (sLit "in Template Haskell:"), +noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+> + text "in Template Haskell:", nest 2 d]) ppr_th :: TH.Ppr a => a -> SDoc diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index b7b27c286d..684853d90f 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -61,7 +61,6 @@ import SrcLoc import ListSetOps import Digraph import DynFlags -import FastString import Unique import BasicTypes import qualified GHC.LanguageExtensions as LangExt @@ -267,7 +266,7 @@ kcTyClGroup :: TyClGroup Name -> TcM [(Name,Kind)] -- See Note [Kind checking for type and class decls] kcTyClGroup (TyClGroup { group_tyclds = decls }) = do { mod <- getModule - ; traceTc "kcTyClGroup" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls)) + ; traceTc "kcTyClGroup" (text "module" <+> ppr mod $$ vcat (map ppr decls)) -- Kind checking; -- 1. Bind kind variables for non-synonyms @@ -962,7 +961,7 @@ tcDefaultAssocDecl _ [] = return Nothing -- No default declaration tcDefaultAssocDecl _ (d1:_:_) - = failWithTc (ptext (sLit "More than one default declaration for") + = failWithTc (text "More than one default declaration for" <+> ppr (tfe_tycon (unLoc d1))) tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name @@ -971,7 +970,7 @@ tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name | HsQTvs { hsq_implicit = imp_vars, hsq_explicit = exp_vars } <- hs_tvs = -- See Note [Type-checking default assoc decls] setSrcSpan loc $ - tcAddFamInstCtxt (ptext (sLit "default type instance")) tc_name $ + tcAddFamInstCtxt (text "default type instance") tc_name $ do { traceTc "tcDefaultAssocDecl" (ppr tc_name) ; let shape@(fam_tc_name, fam_arity, _) = famTyConShape fam_tc @@ -2106,16 +2105,16 @@ checkValidDataCon dflags existential_ok tc con check_bang (HsSrcBang _ _ SrcLazy) _ n | not (xopt LangExt.StrictData dflags) = addErrTc - (bad_bang n (ptext (sLit "Lazy annotation (~) without StrictData"))) + (bad_bang n (text "Lazy annotation (~) without StrictData")) check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n | isSrcUnpacked want_unpack, not is_strict - = addWarnTc (bad_bang n (ptext (sLit "UNPACK pragma lacks '!'"))) + = addWarnTc (bad_bang n (text "UNPACK pragma lacks '!'")) | isSrcUnpacked want_unpack , case rep_bang of { HsUnpack {} -> False; _ -> True } , not (gopt Opt_OmitInterfacePragmas dflags) -- If not optimising, se don't unpack, so don't complain! -- See MkId.dataConArgRep, the (HsBang True) case - = addWarnTc (bad_bang n (ptext (sLit "Ignoring unusable UNPACK pragma"))) + = addWarnTc (bad_bang n (text "Ignoring unusable UNPACK pragma")) where is_strict = case strict_mark of NoSrcStrict -> xopt LangExt.StrictData dflags @@ -2125,8 +2124,8 @@ checkValidDataCon dflags existential_ok tc con = return () bad_bang n herald - = hang herald 2 (ptext (sLit "on the") <+> speakNth n - <+> ptext (sLit "argument of") <+> quotes (ppr con)) + = hang herald 2 (text "on the" <+> speakNth n + <+> text "argument of" <+> quotes (ppr con)) ------------------------------- checkNewDataCon :: DataCon -> TcM () -- Further checks for the data constructor of a newtype @@ -2135,14 +2134,14 @@ checkNewDataCon con -- One argument ; check_con (null eq_spec) $ - ptext (sLit "A newtype constructor must have a return type of form T a1 ... an") + text "A newtype constructor must have a return type of form T a1 ... an" -- Return type is (T a b c) ; check_con (null theta) $ - ptext (sLit "A newtype constructor cannot have a context in its type") + text "A newtype constructor cannot have a context in its type" ; check_con (null ex_tvs) $ - ptext (sLit "A newtype constructor cannot have existential type variables") + text "A newtype constructor cannot have existential type variables" -- No existentials ; checkTc (all ok_bang (dataConSrcBangs con)) @@ -2253,8 +2252,8 @@ checkFamFlag tc_name = do { idx_tys <- xoptM LangExt.TypeFamilies ; checkTc idx_tys err_msg } where - err_msg = hang (ptext (sLit "Illegal family declaration for") <+> quotes (ppr tc_name)) - 2 (ptext (sLit "Use TypeFamilies to allow indexed type families")) + err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name)) + 2 (text "Use TypeFamilies to allow indexed type families") {- Note [Abort when superclass cycle is detected] @@ -2357,11 +2356,11 @@ checkValidRoles tc check_ty_roles env role (TyVarTy tv) = case lookupVarEnv env tv of Just role' -> unless (role' `ltRole` role || role' == role) $ - report_error $ ptext (sLit "type variable") <+> quotes (ppr tv) <+> - ptext (sLit "cannot have role") <+> ppr role <+> - ptext (sLit "because it was assigned role") <+> ppr role' - Nothing -> report_error $ ptext (sLit "type variable") <+> quotes (ppr tv) <+> - ptext (sLit "missing in environment") + report_error $ text "type variable" <+> quotes (ppr tv) <+> + text "cannot have role" <+> ppr role <+> + text "because it was assigned role" <+> ppr role' + Nothing -> report_error $ text "type variable" <+> quotes (ppr tv) <+> + text "missing in environment" check_ty_roles env Representational (TyConApp tc tys) = let roles' = tyConRoles tc in @@ -2399,9 +2398,9 @@ checkValidRoles tc check_ty_roles env role ty report_error doc - = addErrTc $ vcat [ptext (sLit "Internal error in role inference:"), + = addErrTc $ vcat [text "Internal error in role inference:", doc, - ptext (sLit "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug")] + text "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug"] {- ************************************************************************ @@ -2413,7 +2412,7 @@ checkValidRoles tc tcAddTyFamInstCtxt :: TyFamInstDecl Name -> TcM a -> TcM a tcAddTyFamInstCtxt decl - = tcAddFamInstCtxt (ptext (sLit "type instance")) (tyFamInstDeclName decl) + = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl) tcMkDataFamInstCtxt :: DataFamInstDecl Name -> SDoc tcMkDataFamInstCtxt decl @@ -2437,31 +2436,31 @@ tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a tcAddClosedTypeFamilyDeclCtxt tc = addErrCtxt ctxt where - ctxt = ptext (sLit "In the equations for closed type family") <+> + ctxt = text "In the equations for closed type family" <+> quotes (ppr tc) resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc resultTypeMisMatch field_name con1 con2 - = vcat [sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2, - ptext (sLit "have a common field") <+> quotes (ppr field_name) <> comma], - nest 2 $ ptext (sLit "but have different result types")] + = vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, + text "have a common field" <+> quotes (ppr field_name) <> comma], + nest 2 $ text "but have different result types"] fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc fieldTypeMisMatch field_name con1 con2 - = sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2, - ptext (sLit "give different types for field"), quotes (ppr field_name)] + = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, + text "give different types for field", quotes (ppr field_name)] dataConCtxtName :: [Located Name] -> SDoc dataConCtxtName [con] - = ptext (sLit "In the definition of data constructor") <+> quotes (ppr con) + = text "In the definition of data constructor" <+> quotes (ppr con) dataConCtxtName con - = ptext (sLit "In the definition of data constructors") <+> interpp'SP con + = text "In the definition of data constructors" <+> interpp'SP con dataConCtxt :: Outputable a => a -> SDoc -dataConCtxt con = ptext (sLit "In the definition of data constructor") <+> quotes (ppr con) +dataConCtxt con = text "In the definition of data constructor" <+> quotes (ppr con) classOpCtxt :: Var -> Type -> SDoc -classOpCtxt sel_id tau = sep [ptext (sLit "When checking the class method:"), +classOpCtxt sel_id tau = sep [text "When checking the class method:", nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] classArityErr :: Int -> Class -> SDoc @@ -2470,32 +2469,32 @@ classArityErr n cls | otherwise = mkErr "Too many" "multi-parameter" where mkErr howMany allowWhat = - vcat [ptext (sLit $ howMany ++ " parameters for class") <+> quotes (ppr cls), - parens (ptext (sLit $ "Use MultiParamTypeClasses to allow " + vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls), + parens (text ("Use MultiParamTypeClasses to allow " ++ allowWhat ++ " classes"))] classFunDepsErr :: Class -> SDoc classFunDepsErr cls - = vcat [ptext (sLit "Fundeps in class") <+> quotes (ppr cls), - parens (ptext (sLit "Use FunctionalDependencies to allow fundeps"))] + = vcat [text "Fundeps in class" <+> quotes (ppr cls), + parens (text "Use FunctionalDependencies to allow fundeps")] badMethPred :: Id -> TcPredType -> SDoc badMethPred sel_id pred - = vcat [ hang (ptext (sLit "Constraint") <+> quotes (ppr pred) - <+> ptext (sLit "in the type of") <+> quotes (ppr sel_id)) - 2 (ptext (sLit "constrains only the class type variables")) - , ptext (sLit "Use ConstrainedClassMethods to allow it") ] + = vcat [ hang (text "Constraint" <+> quotes (ppr pred) + <+> text "in the type of" <+> quotes (ppr sel_id)) + 2 (text "constrains only the class type variables") + , text "Use ConstrainedClassMethods to allow it" ] noClassTyVarErr :: Class -> TyCon -> SDoc noClassTyVarErr clas fam_tc - = sep [ ptext (sLit "The associated type") <+> quotes (ppr fam_tc) - , ptext (sLit "mentions none of the type or kind variables of the class") <+> + = sep [ text "The associated type" <+> quotes (ppr fam_tc) + , text "mentions none of the type or kind variables of the class" <+> quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))] recSynErr :: [LTyClDecl Name] -> TcRn () recSynErr syn_decls = setSrcSpan (getLoc (head sorted_decls)) $ - addErr (sep [ptext (sLit "Cycle in type synonym declarations:"), + addErr (sep [text "Cycle in type synonym declarations:", nest 2 (vcat (map ppr_decl sorted_decls))]) where sorted_decls = sortLocated syn_decls @@ -2503,55 +2502,55 @@ recSynErr syn_decls badDataConTyCon :: DataCon -> Type -> Type -> SDoc badDataConTyCon data_con res_ty_tmpl actual_res_ty - = hang (ptext (sLit "Data constructor") <+> quotes (ppr data_con) <+> - ptext (sLit "returns type") <+> quotes (ppr actual_res_ty)) - 2 (ptext (sLit "instead of an instance of its parent type") <+> quotes (ppr res_ty_tmpl)) + = hang (text "Data constructor" <+> quotes (ppr data_con) <+> + text "returns type" <+> quotes (ppr actual_res_ty)) + 2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl)) badGadtDecl :: Name -> SDoc badGadtDecl tc_name - = vcat [ ptext (sLit "Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext (sLit "Use GADTs to allow GADTs")) ] + = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name) + , nest 2 (parens $ text "Use GADTs to allow GADTs") ] badExistential :: DataCon -> SDoc badExistential con - = hang (ptext (sLit "Data constructor") <+> quotes (ppr con) <+> - ptext (sLit "has existential type variables, a context, or a specialised result type")) + = hang (text "Data constructor" <+> quotes (ppr con) <+> + text "has existential type variables, a context, or a specialised result type") 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con) - , parens $ ptext (sLit "Use ExistentialQuantification or GADTs to allow this") ]) + , parens $ text "Use ExistentialQuantification or GADTs to allow this" ]) badStupidTheta :: Name -> SDoc badStupidTheta tc_name - = ptext (sLit "A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name) + = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) newtypeConError :: Name -> Int -> SDoc newtypeConError tycon n - = sep [ptext (sLit "A newtype must have exactly one constructor,"), - nest 2 $ ptext (sLit "but") <+> quotes (ppr tycon) <+> ptext (sLit "has") <+> speakN n ] + = sep [text "A newtype must have exactly one constructor,", + nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] newtypeStrictError :: DataCon -> SDoc newtypeStrictError con - = sep [ptext (sLit "A newtype constructor cannot have a strictness annotation,"), - nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")] + = sep [text "A newtype constructor cannot have a strictness annotation,", + nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"] newtypeFieldErr :: DataCon -> Int -> SDoc newtypeFieldErr con_name n_flds - = sep [ptext (sLit "The constructor of a newtype must have exactly one field"), - nest 2 $ ptext (sLit "but") <+> quotes (ppr con_name) <+> ptext (sLit "has") <+> speakN n_flds] + = sep [text "The constructor of a newtype must have exactly one field", + nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds] badSigTyDecl :: Name -> SDoc badSigTyDecl tc_name - = vcat [ ptext (sLit "Illegal kind signature") <+> + = vcat [ text "Illegal kind signature" <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext (sLit "Use KindSignatures to allow kind signatures")) ] + , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ] emptyConDeclsErr :: Name -> SDoc emptyConDeclsErr tycon - = sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"), - nest 2 $ ptext (sLit "(EmptyDataDecls permits this)")] + = sep [quotes (ppr tycon) <+> text "has no constructors", + nest 2 $ text "(EmptyDataDecls permits this)"] wrongKindOfFamily :: TyCon -> SDoc wrongKindOfFamily family - = ptext (sLit "Wrong category of family instance; declaration was for a") + = text "Wrong category of family instance; declaration was for a" <+> kindOfFamily where kindOfFamily | isTypeFamilyTyCon family = text "type family" @@ -2560,45 +2559,45 @@ wrongKindOfFamily family wrongNumberOfParmsErr :: Arity -> SDoc wrongNumberOfParmsErr max_args - = ptext (sLit "Number of parameters must match family declaration; expected") + = text "Number of parameters must match family declaration; expected" <+> ppr max_args defaultAssocKindErr :: TyCon -> SDoc defaultAssocKindErr fam_tc - = ptext (sLit "Kind mis-match on LHS of default declaration for") + = text "Kind mis-match on LHS of default declaration for" <+> quotes (ppr fam_tc) wrongTyFamName :: Name -> Name -> SDoc wrongTyFamName fam_tc_name eqn_tc_name - = hang (ptext (sLit "Mismatched type name in type family instance.")) - 2 (vcat [ ptext (sLit "Expected:") <+> ppr fam_tc_name - , ptext (sLit " Actual:") <+> ppr eqn_tc_name ]) + = hang (text "Mismatched type name in type family instance.") + 2 (vcat [ text "Expected:" <+> ppr fam_tc_name + , text " Actual:" <+> ppr eqn_tc_name ]) badRoleAnnot :: Name -> Role -> Role -> SDoc badRoleAnnot var annot inferred - = hang (ptext (sLit "Role mismatch on variable") <+> ppr var <> colon) - 2 (sep [ ptext (sLit "Annotation says"), ppr annot - , ptext (sLit "but role"), ppr inferred - , ptext (sLit "is required") ]) + = hang (text "Role mismatch on variable" <+> ppr var <> colon) + 2 (sep [ text "Annotation says", ppr annot + , text "but role", ppr inferred + , text "is required" ]) wrongNumberOfRoles :: [a] -> LRoleAnnotDecl Name -> SDoc wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ annots)) - = hang (ptext (sLit "Wrong number of roles listed in role annotation;") $$ - ptext (sLit "Expected") <+> (ppr $ length tyvars) <> comma <+> - ptext (sLit "got") <+> (ppr $ length annots) <> colon) + = hang (text "Wrong number of roles listed in role annotation;" $$ + text "Expected" <+> (ppr $ length tyvars) <> comma <+> + text "got" <+> (ppr $ length annots) <> colon) 2 (ppr d) illegalRoleAnnotDecl :: LRoleAnnotDecl Name -> TcM () illegalRoleAnnotDecl (L loc (RoleAnnotDecl tycon _)) = setErrCtxt [] $ setSrcSpan loc $ - addErrTc (ptext (sLit "Illegal role annotation for") <+> ppr tycon <> char ';' $$ - ptext (sLit "they are allowed only for datatypes and classes.")) + addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ + text "they are allowed only for datatypes and classes.") needXRoleAnnotations :: TyCon -> SDoc needXRoleAnnotations tc - = ptext (sLit "Illegal role annotation for") <+> ppr tc <> char ';' $$ - ptext (sLit "did you intend to use RoleAnnotations?") + = text "Illegal role annotation for" <+> ppr tc <> char ';' $$ + text "did you intend to use RoleAnnotations?" incoherentRoles :: SDoc incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+> @@ -2611,8 +2610,8 @@ addTyConCtxt tc where name = getName tc flav = text (tyConFlavour tc) - ctxt = hsep [ ptext (sLit "In the"), flav - , ptext (sLit "declaration for"), quotes (ppr name) ] + ctxt = hsep [ text "In the", flav + , text "declaration for", quotes (ppr name) ] addRoleAnnotCtxt :: Name -> TcM a -> TcM a addRoleAnnotCtxt name diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index c2f017d0cf..2517c46a2c 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -191,12 +191,12 @@ checkClassCycles :: Class -> Maybe SDoc checkClassCycles cls = do { (definite_cycle, err) <- go (unitNameSet (getName cls)) cls (mkTyVarTys (classTyVars cls)) - ; let herald | definite_cycle = ptext (sLit "Superclass cycle for") - | otherwise = ptext (sLit "Potential superclass cycle for") + ; let herald | definite_cycle = text "Superclass cycle for" + | otherwise = text "Potential superclass cycle for" ; return (vcat [ herald <+> quotes (ppr cls) , nest 2 err, hint]) } where - hint = ptext (sLit "Use UndecidableSuperClasses to accept this") + hint = text "Use UndecidableSuperClasses to accept this" -- Expand superclasses starting with (C a b), complaining -- if you find the same class a second time, or a type function @@ -218,7 +218,7 @@ checkClassCycles cls | Just (tc, tys) <- tcSplitTyConApp_maybe pred = go_tc so_far pred tc tys | hasTyVarHead pred - = Just (False, hang (ptext (sLit "one of whose superclass constraints is headed by a type variable:")) + = Just (False, hang (text "one of whose superclass constraints is headed by a type variable:") 2 (quotes (ppr pred))) | otherwise = Nothing @@ -226,7 +226,7 @@ checkClassCycles cls go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc) go_tc so_far pred tc tys | isFamilyTyCon tc - = Just (False, hang (ptext (sLit "one of whose superclass constraints is headed by a type family:")) + = Just (False, hang (text "one of whose superclass constraints is headed by a type family:") 2 (quotes (ppr pred))) | Just cls <- tyConClass_maybe tc = go_cls so_far cls tys @@ -236,12 +236,12 @@ checkClassCycles cls go_cls :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc) go_cls so_far cls tys | cls_nm `elemNameSet` so_far - = Just (True, ptext (sLit "one of whose superclasses is") <+> quotes (ppr cls)) + = Just (True, text "one of whose superclasses is" <+> quotes (ppr cls)) | isCTupleClass cls = go so_far cls tys | otherwise = do { (b,err) <- go (so_far `extendNameSet` cls_nm) cls tys - ; return (b, ptext (sLit "one of whose superclasses is") <+> quotes (ppr cls) + ; return (b, text "one of whose superclasses is" <+> quotes (ppr cls) $$ err) } where cls_nm = getName cls diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index fca5f475a3..2f00be2fe8 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -384,8 +384,8 @@ data MetaDetails | Indirect TcType instance Outputable MetaDetails where - ppr Flexi = ptext (sLit "Flexi") - ppr (Indirect ty) = ptext (sLit "Indirect") <+> ppr ty + ppr Flexi = text "Flexi" + ppr (Indirect ty) = text "Indirect" <+> ppr ty data TauTvFlavour = VanillaTau @@ -599,40 +599,40 @@ instance Outputable TcLevel where pprTcTyVarDetails :: TcTyVarDetails -> SDoc -- For debugging -pprTcTyVarDetails (SkolemTv True) = ptext (sLit "ssk") -pprTcTyVarDetails (SkolemTv False) = ptext (sLit "sk") -pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt") -pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk") +pprTcTyVarDetails (SkolemTv True) = text "ssk" +pprTcTyVarDetails (SkolemTv False) = text "sk" +pprTcTyVarDetails (RuntimeUnk {}) = text "rt" +pprTcTyVarDetails (FlatSkol {}) = text "fsk" pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl }) = pp_info <> colon <> ppr tclvl where pp_info = case info of - ReturnTv -> ptext (sLit "ret") - TauTv -> ptext (sLit "tau") - SigTv -> ptext (sLit "sig") - FlatMetaTv -> ptext (sLit "fuv") + ReturnTv -> text "ret" + TauTv -> text "tau" + SigTv -> text "sig" + FlatMetaTv -> text "fuv" pprUserTypeCtxt :: UserTypeCtxt -> SDoc -pprUserTypeCtxt (FunSigCtxt n _) = ptext (sLit "the type signature for") <+> quotes (ppr n) -pprUserTypeCtxt (InfSigCtxt n) = ptext (sLit "the inferred type for") <+> quotes (ppr n) -pprUserTypeCtxt (RuleSigCtxt n) = ptext (sLit "a RULE for") <+> quotes (ppr n) -pprUserTypeCtxt ExprSigCtxt = ptext (sLit "an expression type signature") -pprUserTypeCtxt TypeAppCtxt = ptext (sLit "a type argument") -pprUserTypeCtxt (ConArgCtxt c) = ptext (sLit "the type of the constructor") <+> quotes (ppr c) -pprUserTypeCtxt (TySynCtxt c) = ptext (sLit "the RHS of the type synonym") <+> quotes (ppr c) -pprUserTypeCtxt (PatSynCtxt c) = ptext (sLit "the type signature for pattern synonym") <+> quotes (ppr c) -pprUserTypeCtxt ThBrackCtxt = ptext (sLit "a Template Haskell quotation [t|...|]") -pprUserTypeCtxt PatSigCtxt = ptext (sLit "a pattern type signature") -pprUserTypeCtxt ResSigCtxt = ptext (sLit "a result type signature") -pprUserTypeCtxt (ForSigCtxt n) = ptext (sLit "the foreign declaration for") <+> quotes (ppr n) -pprUserTypeCtxt DefaultDeclCtxt = ptext (sLit "a type in a `default' declaration") -pprUserTypeCtxt InstDeclCtxt = ptext (sLit "an instance declaration") -pprUserTypeCtxt SpecInstCtxt = ptext (sLit "a SPECIALISE instance pragma") -pprUserTypeCtxt GenSigCtxt = ptext (sLit "a type expected by the context") -pprUserTypeCtxt GhciCtxt = ptext (sLit "a type in a GHCi command") -pprUserTypeCtxt (ClassSCCtxt c) = ptext (sLit "the super-classes of class") <+> quotes (ppr c) -pprUserTypeCtxt SigmaCtxt = ptext (sLit "the context of a polymorphic type") -pprUserTypeCtxt (DataTyCtxt tc) = ptext (sLit "the context of the data type declaration for") <+> quotes (ppr tc) +pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n) +pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n) +pprUserTypeCtxt (RuleSigCtxt n) = text "a RULE for" <+> quotes (ppr n) +pprUserTypeCtxt ExprSigCtxt = text "an expression type signature" +pprUserTypeCtxt TypeAppCtxt = text "a type argument" +pprUserTypeCtxt (ConArgCtxt c) = text "the type of the constructor" <+> quotes (ppr c) +pprUserTypeCtxt (TySynCtxt c) = text "the RHS of the type synonym" <+> quotes (ppr c) +pprUserTypeCtxt (PatSynCtxt c) = text "the type signature for pattern synonym" <+> quotes (ppr c) +pprUserTypeCtxt ThBrackCtxt = text "a Template Haskell quotation [t|...|]" +pprUserTypeCtxt PatSigCtxt = text "a pattern type signature" +pprUserTypeCtxt ResSigCtxt = text "a result type signature" +pprUserTypeCtxt (ForSigCtxt n) = text "the foreign declaration for" <+> quotes (ppr n) +pprUserTypeCtxt DefaultDeclCtxt = text "a type in a `default' declaration" +pprUserTypeCtxt InstDeclCtxt = text "an instance declaration" +pprUserTypeCtxt SpecInstCtxt = text "a SPECIALISE instance pragma" +pprUserTypeCtxt GenSigCtxt = text "a type expected by the context" +pprUserTypeCtxt GhciCtxt = text "a type in a GHCi command" +pprUserTypeCtxt (ClassSCCtxt c) = text "the super-classes of class" <+> quotes (ppr c) +pprUserTypeCtxt SigmaCtxt = text "the context of a polymorphic type" +pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declaration for" <+> quotes (ppr tc) pprSigCtxt :: UserTypeCtxt -> SDoc -> SDoc -> SDoc -- (pprSigCtxt ctxt <extra> <type>) @@ -641,11 +641,11 @@ pprSigCtxt :: UserTypeCtxt -> SDoc -> SDoc -> SDoc -- The <extra> is either empty or "the ambiguity check for" pprSigCtxt ctxt extra pp_ty | Just n <- isSigMaybe ctxt - = vcat [ ptext (sLit "In") <+> extra <+> ptext (sLit "the type signature:") + = vcat [ text "In" <+> extra <+> ptext (sLit "the type signature:") , nest 2 (pprPrefixOcc n <+> dcolon <+> pp_ty) ] | otherwise - = hang (ptext (sLit "In") <+> extra <+> pprUserTypeCtxt ctxt <> colon) + = hang (text "In" <+> extra <+> pprUserTypeCtxt ctxt <> colon) 2 pp_ty where @@ -2109,8 +2109,8 @@ isFFIDynTy expected ty , eqType ty' expected = IsValid | otherwise - = NotValid (vcat [ ptext (sLit "Expected: Ptr/FunPtr") <+> pprParendType expected <> comma - , ptext (sLit " Actual:") <+> ppr ty ]) + = NotValid (vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma + , text " Actual:" <+> ppr ty ]) isFFILabelTy :: Type -> Validity -- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. @@ -2119,7 +2119,7 @@ isFFILabelTy ty = checkRepTyCon ok ty ok tc | tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey = IsValid | otherwise - = NotValid (ptext (sLit "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)")) + = NotValid (text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)") isFFIPrimArgumentTy :: DynFlags -> Type -> Validity -- Checks for valid argument type for a 'foreign import prim' @@ -2156,14 +2156,14 @@ checkRepTyCon check_tc ty | otherwise -> case check_tc tc of IsValid -> IsValid NotValid extra -> NotValid (msg $$ extra) - Nothing -> NotValid (quotes (ppr ty) <+> ptext (sLit "is not a data type")) + Nothing -> NotValid (quotes (ppr ty) <+> text "is not a data type") where - msg = quotes (ppr ty) <+> ptext (sLit "cannot be marshalled in a foreign call") + msg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call" mk_nt_reason tc tys - | null tys = ptext (sLit "because its data constructor is not in scope") - | otherwise = ptext (sLit "because the data constructor for") - <+> quotes (ppr tc) <+> ptext (sLit "is not in scope") - nt_fix = ptext (sLit "Possible fix: import the data constructor to bring it into scope") + | null tys = text "because its data constructor is not in scope" + | otherwise = text "because the data constructor for" + <+> quotes (ppr tc) <+> text "is not in scope" + nt_fix = text "Possible fix: import the data constructor to bring it into scope" {- Note [Foreign import dynamic] @@ -2267,12 +2267,12 @@ legalFIPrimResultTyCon dflags tc = NotValid unlifted_only unlifted_only :: MsgDoc -unlifted_only = ptext (sLit "foreign import prim only accepts simple unlifted types") +unlifted_only = text "foreign import prim only accepts simple unlifted types" validIfUnliftedFFITypes :: DynFlags -> Validity validIfUnliftedFFITypes dflags | xopt LangExt.UnliftedFFITypes dflags = IsValid - | otherwise = NotValid (ptext (sLit "To marshal unlifted types, use UnliftedFFITypes")) + | otherwise = NotValid (text "To marshal unlifted types, use UnliftedFFITypes") {- Note [Marshalling VoidRep] diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index 33525be64a..a548e8d86a 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -281,12 +281,12 @@ match_fun_tys swap_tys herald ct_orig arity orig_ty orig_old_args full_arity mk_msg full_ty ty n_args = herald <+> speakNOf full_arity (text "argument") <> comma $$ if n_args == full_arity - then ptext (sLit "its type is") <+> quotes (pprType full_ty) <> + then text "its type is" <+> quotes (pprType full_ty) <> comma $$ - ptext (sLit "it is specialized to") <+> quotes (pprType ty) - else sep [ptext (sLit "but its type") <+> quotes (pprType ty), - if n_args == 0 then ptext (sLit "has none") - else ptext (sLit "has only") <+> speakN n_args] + text "it is specialized to" <+> quotes (pprType ty) + else sep [text "but its type" <+> quotes (pprType ty), + if n_args == 0 then text "has none" + else text "has only" <+> speakN n_args] ---------------------- matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType) @@ -539,9 +539,9 @@ addSubTypeCtxt ty_actual ty_expected thing_inside mk_msg tidy_env = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected - ; let msg = vcat [ hang (ptext (sLit "When checking that:")) + ; let msg = vcat [ hang (text "When checking that:") 4 (ppr ty_actual) - , nest 2 (hang (ptext (sLit "is more polymorphic than:")) + , nest 2 (hang (text "is more polymorphic than:") 2 (ppr ty_expected)) ] ; return (tidy_env, msg) } @@ -922,8 +922,8 @@ unifyTheta :: TcThetaType -> TcThetaType -> TcM [TcCoercion] -- Actual and expected types unifyTheta theta1 theta2 = do { checkTc (equalLength theta1 theta2) - (vcat [ptext (sLit "Contexts differ in length"), - nest 2 $ parens $ ptext (sLit "Use RelaxedPolyRec to allow this")]) + (vcat [text "Contexts differ in length", + nest 2 $ parens $ text "Use RelaxedPolyRec to allow this"]) ; zipWithM unifyPred theta1 theta2 } {- diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index a783fb13a0..54e04b85ec 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -51,7 +51,6 @@ import Util import ListSetOps import SrcLoc import Outputable -import FastString import BasicTypes import Module import qualified GHC.LanguageExtensions as LangExt @@ -210,9 +209,9 @@ checkAmbiguity ctxt ty = return () where mk_msg allow_ambiguous - = vcat [ ptext (sLit "In the ambiguity check for") <+> what + = vcat [ text "In the ambiguity check for" <+> what , ppUnless allow_ambiguous ambig_msg ] - ambig_msg = ptext (sLit "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes") + ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes" what | Just n <- isSigMaybe ctxt = quotes (ppr n) | otherwise = pprUserTypeCtxt ctxt @@ -415,9 +414,9 @@ data Rank = ArbitraryRank -- Any rank ok | MustBeMonoType -- Monotype regardless of flags rankZeroMonoType, tyConArgMonoType, synArgMonoType :: Rank -rankZeroMonoType = MonoType (ptext (sLit "Perhaps you intended to use RankNTypes or Rank2Types")) -tyConArgMonoType = MonoType (ptext (sLit "GHC doesn't yet support impredicative polymorphism")) -synArgMonoType = MonoType (ptext (sLit "Perhaps you intended to use LiberalTypeSynonyms")) +rankZeroMonoType = MonoType (text "Perhaps you intended to use RankNTypes or Rank2Types") +tyConArgMonoType = MonoType (text "GHC doesn't yet support impredicative polymorphism") +synArgMonoType = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms") funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank) @@ -583,11 +582,11 @@ check_arg_type env ctxt rank ty forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc) forAllTyErr env rank ty = ( env - , vcat [ hang (ptext (sLit "Illegal polymorphic or qualified type:")) 2 (ppr_tidy env ty) + , vcat [ hang (text "Illegal polymorphic or qualified type:") 2 (ppr_tidy env ty) , suggestion ] ) where suggestion = case rank of - LimitedRank {} -> ptext (sLit "Perhaps you intended to use RankNTypes or Rank2Types") + LimitedRank {} -> text "Perhaps you intended to use RankNTypes or Rank2Types" MonoType d -> d _ -> Outputable.empty -- Polytype is always illegal @@ -600,11 +599,11 @@ forAllEscapeErr env ty tau_kind , text "of kind:" <+> ppr_tidy env tau_kind ]) ) unliftedArgErr, ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc) -unliftedArgErr env ty = (env, sep [ptext (sLit "Illegal unlifted type:"), ppr_tidy env ty]) -ubxArgTyErr env ty = (env, sep [ptext (sLit "Illegal unboxed tuple type as function argument:"), ppr_tidy env ty]) +unliftedArgErr env ty = (env, sep [text "Illegal unlifted type:", ppr_tidy env ty]) +ubxArgTyErr env ty = (env, sep [text "Illegal unboxed tuple type as function argument:", ppr_tidy env ty]) kindErr :: TidyEnv -> Kind -> (TidyEnv, SDoc) -kindErr env kind = (env, sep [ptext (sLit "Expecting an ordinary type, but found a type of kind"), ppr_tidy env kind]) +kindErr env kind = (env, sep [text "Expecting an ordinary type, but found a type of kind", ppr_tidy env kind]) {- Note [Liberal type synonyms] @@ -826,7 +825,7 @@ okIPCtxt DefaultDeclCtxt = False badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc) badIPPred env pred = ( env - , ptext (sLit "Illegal implicit parameter") <+> quotes (ppr_tidy env pred) ) + , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) ) {- Note [Kind polymorphic type classes] @@ -852,38 +851,38 @@ Flexibility check: checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (TidyEnv, SDoc) checkThetaCtxt ctxt theta env = return ( env - , vcat [ ptext (sLit "In the context:") <+> pprTheta (tidyTypes env theta) - , ptext (sLit "While checking") <+> pprUserTypeCtxt ctxt ] ) + , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta) + , text "While checking" <+> pprUserTypeCtxt ctxt ] ) eqPredTyErr, predTupleErr, predIrredErr, predSuperClassErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) eqPredTyErr env pred = ( env - , ptext (sLit "Illegal equational constraint") <+> ppr_tidy env pred $$ - parens (ptext (sLit "Use GADTs or TypeFamilies to permit this")) ) + , text "Illegal equational constraint" <+> ppr_tidy env pred $$ + parens (text "Use GADTs or TypeFamilies to permit this") ) predTupleErr env pred = ( env - , hang (ptext (sLit "Illegal tuple constraint:") <+> ppr_tidy env pred) + , hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred) 2 (parens constraintKindsMsg) ) predIrredErr env pred = ( env - , hang (ptext (sLit "Illegal constraint:") <+> ppr_tidy env pred) + , hang (text "Illegal constraint:" <+> ppr_tidy env pred) 2 (parens constraintKindsMsg) ) predSuperClassErr env pred = ( env - , hang (ptext (sLit "Illegal constraint") <+> quotes (ppr_tidy env pred) - <+> ptext (sLit "in a superclass context")) + , hang (text "Illegal constraint" <+> quotes (ppr_tidy env pred) + <+> text "in a superclass context") 2 (parens undecidableMsg) ) predTyVarErr :: PredType -> SDoc -- type is already tidied! predTyVarErr pred - = vcat [ hang (ptext (sLit "Non type-variable argument")) - 2 (ptext (sLit "in the constraint:") <+> ppr pred) - , parens (ptext (sLit "Use FlexibleContexts to permit this")) ] + = vcat [ hang (text "Non type-variable argument") + 2 (text "in the constraint:" <+> ppr pred) + , parens (text "Use FlexibleContexts to permit this") ] constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc) constraintSynErr env kind = ( env - , hang (ptext (sLit "Illegal constraint synonym of kind:") <+> quotes (ppr_tidy env kind)) + , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind)) 2 (parens constraintKindsMsg) ) dupPredWarn :: TidyEnv -> [[PredType]] -> (TidyEnv, SDoc) @@ -912,13 +911,13 @@ tyConArityErr tc tks arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc arityErr what name n m - = hsep [ ptext (sLit "The") <+> text what, quotes (ppr name), ptext (sLit "should have"), + = hsep [ text "The" <+> text what, quotes (ppr name), text "should have", n_arguments <> comma, text "but has been given", if m==0 then text "none" else int m] where - n_arguments | n == 0 = ptext (sLit "no arguments") - | n == 1 = ptext (sLit "1 argument") - | True = hsep [int n, ptext (sLit "arguments")] + n_arguments | n == 0 = text "no arguments" + | n == 1 = text "1 argument" + | True = hsep [int n, text "arguments"] {- ************************************************************************ @@ -1007,7 +1006,7 @@ abstractClassKeys = [ heqTyConKey instTypeErr :: Class -> [Type] -> SDoc -> SDoc instTypeErr cls tys msg - = hang (hang (ptext (sLit "Illegal instance declaration for")) + = hang (hang (text "Illegal instance declaration for") 2 (quotes (pprClassPred cls tys))) 2 msg @@ -1100,7 +1099,7 @@ checkValidInstance ctxt hs_type ty ; return (tvs, theta, clas, inst_tys) } | otherwise - = failWithTc (ptext (sLit "Malformed instance head:") <+> ppr tau) + = failWithTc (text "Malformed instance head:" <+> ppr tau) where (tvs, theta, tau) = tcSplitSigmaTy ty @@ -1160,29 +1159,29 @@ checkInstTermination tys theta | pred_size >= head_size = addErrTc (smallerMsg what) | otherwise = return () where - what = ptext (sLit "constraint") <+> quotes (ppr pred) + what = text "constraint" <+> quotes (ppr pred) bad_tvs = fvType pred \\ head_fvs smallerMsg :: SDoc -> SDoc smallerMsg what - = vcat [ hang (ptext (sLit "The") <+> what) - 2 (ptext (sLit "is no smaller than the instance head")) + = vcat [ hang (text "The" <+> what) + 2 (text "is no smaller than the instance head") , parens undecidableMsg ] noMoreMsg :: [TcTyVar] -> SDoc -> SDoc noMoreMsg tvs what - = vcat [ hang (ptext (sLit "Variable") <> plural tvs <+> quotes (pprWithCommas ppr tvs) - <+> occurs <+> ptext (sLit "more often")) - 2 (sep [ ptext (sLit "in the") <+> what - , ptext (sLit "than in the instance head") ]) + = vcat [ hang (text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs) + <+> occurs <+> text "more often") + 2 (sep [ text "in the" <+> what + , text "than in the instance head" ]) , parens undecidableMsg ] where - occurs = if isSingleton tvs then ptext (sLit "occurs") - else ptext (sLit "occur") + occurs = if isSingleton tvs then text "occurs" + else text "occur" undecidableMsg, constraintKindsMsg :: SDoc -undecidableMsg = ptext (sLit "Use UndecidableInstances to permit this") -constraintKindsMsg = ptext (sLit "Use ConstraintKinds to permit this") +undecidableMsg = text "Use UndecidableInstances to permit this" +constraintKindsMsg = text "Use ConstraintKinds to permit this" {- Note [Associated type instances] @@ -1307,14 +1306,14 @@ checkConsistentFamInst (Just (clas, mini_env)) fam_tc at_tvs at_tys badATErr :: Name -> Name -> SDoc badATErr clas op - = hsep [ptext (sLit "Class"), quotes (ppr clas), - ptext (sLit "does not have an associated type"), quotes (ppr op)] + = hsep [text "Class", quotes (ppr clas), + text "does not have an associated type", quotes (ppr op)] wrongATArgErr :: Type -> Type -> SDoc wrongATArgErr ty instTy = - sep [ ptext (sLit "Type indexes must match class instance head") - , ptext (sLit "Found") <+> quotes (ppr ty) - <+> ptext (sLit "but expected") <+> quotes (ppr instTy) + sep [ text "Type indexes must match class instance head" + , text "Found" <+> quotes (ppr ty) + <+> text "but expected" <+> quotes (ppr instTy) ] {- @@ -1443,7 +1442,7 @@ checkFamInstRhs lhsTys famInsts | size <= sizeTypes tys = Just (smallerMsg what) | otherwise = Nothing where - what = ptext (sLit "type family application") <+> quotes (pprType (TyConApp tc tys)) + what = text "type family application" <+> quotes (pprType (TyConApp tc tys)) bad_tvs = fvTypes tys \\ fvs checkValidFamPats :: TyCon -> [TyVar] -> [CoVar] -> [Type] -> TcM () @@ -1473,7 +1472,7 @@ checkValidFamPats fam_tc tvs cvs ty_pats wrongNumberOfParmsErr :: Arity -> SDoc wrongNumberOfParmsErr exp_arity - = ptext (sLit "Number of parameters must match family declaration; expected") + = text "Number of parameters must match family declaration; expected" <+> ppr exp_arity -- Ensure that no type family instances occur in a type. @@ -1491,26 +1490,27 @@ isTyFamFree = null . tcTyFamInsts inaccessibleCoAxBranch :: CoAxiom br -> CoAxBranch -> SDoc inaccessibleCoAxBranch fi_ax cur_branch - = ptext (sLit "Type family instance equation is overlapped:") $$ + = text "Type family instance equation is overlapped:" $$ nest 2 (pprCoAxBranch fi_ax cur_branch) tyFamInstIllegalErr :: Type -> SDoc tyFamInstIllegalErr ty - = hang (ptext (sLit "Illegal type synonym family application in instance") <> + = hang (text "Illegal type synonym family application in instance" <> colon) 2 $ ppr ty nestedMsg :: SDoc -> SDoc nestedMsg what - = sep [ ptext (sLit "Illegal nested") <+> what + = sep [ text "Illegal nested" <+> what , parens undecidableMsg ] famPatErr :: TyCon -> [TyVar] -> [Type] -> SDoc famPatErr fam_tc tvs pats - = hang (ptext (sLit "Family instance purports to bind type variable") <> plural tvs + = hang (text "Family instance purports to bind type variable" <> plural tvs <+> pprQuotedList tvs) - 2 (hang (ptext (sLit "but the real LHS (expanding synonyms) is:")) - 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats) <+> ptext (sLit "= ..."))) + 2 (hang (text "but the real LHS (expanding synonyms) is:") + 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats) <+> + text "= ...")) {- ************************************************************************ diff --git a/compiler/types/Class.hs b/compiler/types/Class.hs index c56fa251e5..3337f0e0cd 100644 --- a/compiler/types/Class.hs +++ b/compiler/types/Class.hs @@ -34,7 +34,6 @@ import SrcLoc import PrelNames ( eqTyConKey, coercibleTyConKey, typeableClassKey, heqTyConKey ) import Outputable -import FastString import BooleanFormula (BooleanFormula) import Data.Typeable (Typeable) @@ -300,8 +299,8 @@ instance Outputable Class where pprDefMethInfo :: DefMethInfo -> SDoc pprDefMethInfo Nothing = empty -- No default method -pprDefMethInfo (Just (n, VanillaDM)) = ptext (sLit "Default method") <+> ppr n -pprDefMethInfo (Just (n, GenericDM ty)) = ptext (sLit "Generic default method") +pprDefMethInfo (Just (n, VanillaDM)) = text "Default method" <+> ppr n +pprDefMethInfo (Just (n, GenericDM ty)) = text "Generic default method" <+> ppr n <+> dcolon <+> ppr ty pprFundeps :: Outputable a => [FunDep a] -> SDoc @@ -309,7 +308,7 @@ pprFundeps [] = empty pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds)) pprFunDep :: Outputable a => FunDep a -> SDoc -pprFunDep (us, vs) = hsep [interppSP us, ptext (sLit "->"), interppSP vs] +pprFunDep (us, vs) = hsep [interppSP us, text "->", interppSP vs] instance Data.Data Class where -- don't traverse? diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs index f8a2533d4e..97fa211136 100644 --- a/compiler/types/Coercion.hs +++ b/compiler/types/Coercion.hs @@ -124,7 +124,6 @@ import ListSetOps import Maybes import Control.Monad (foldM) -import FastString import Control.Arrow ( first ) import Data.Function ( on ) @@ -223,10 +222,10 @@ ppr_co p co@(TransCo {}) = maybeParen p FunPrec $ (co:cos) -> sep ( ppr_co FunPrec co : [ char ';' <+> ppr_co FunPrec co | co <- cos]) ppr_co p (InstCo co arg) = maybeParen p TyConPrec $ - pprParendCo co <> ptext (sLit "@") <> ppr_co TopPrec arg + pprParendCo co <> text "@" <> ppr_co TopPrec arg ppr_co p (UnivCo UnsafeCoerceProv r ty1 ty2) - = pprPrefixApp p (ptext (sLit "UnsafeCo") <+> ppr r) + = pprPrefixApp p (text "UnsafeCo" <+> ppr r) [pprParendType ty1, pprParendType ty2] ppr_co _ (UnivCo p r t1 t2)= angleBrackets ( ppr t1 <> comma <+> ppr t2 ) <> ppr_role r <> ppr_prov where @@ -234,14 +233,14 @@ ppr_co _ (UnivCo p r t1 t2)= angleBrackets ( ppr t1 <> comma <+> ppr t2 ) <> ppr HoleProv h -> ppr h PhantomProv kind_co -> braces (ppr kind_co) _ -> empty -ppr_co p (SymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendCo co] -ppr_co p (NthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <> int n) [pprParendCo co] +ppr_co p (SymCo co) = pprPrefixApp p (text "Sym") [pprParendCo co] +ppr_co p (NthCo n co) = pprPrefixApp p (text "Nth:" <> int n) [pprParendCo co] ppr_co p (LRCo sel co) = pprPrefixApp p (ppr sel) [pprParendCo co] ppr_co p (CoherenceCo c1 c2) = maybeParen p TyConPrec $ - (ppr_co FunPrec c1) <+> (ptext (sLit "|>")) <+> + (ppr_co FunPrec c1) <+> (text "|>") <+> (ppr_co FunPrec c2) -ppr_co p (KindCo co) = pprPrefixApp p (ptext (sLit "kind")) [pprParendCo co] -ppr_co p (SubCo co) = pprPrefixApp p (ptext (sLit "Sub")) [pprParendCo co] +ppr_co p (KindCo co) = pprPrefixApp p (text "kind") [pprParendCo co] +ppr_co p (SubCo co) = pprPrefixApp p (text "Sub") [pprParendCo co] ppr_co p (AxiomRuleCo co cs) = maybeParen p TopPrec $ ppr_axiom_rule_co co cs ppr_axiom_rule_co :: CoAxiomRule -> [Coercion] -> SDoc diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs index 216d39216c..4b4cc5d2f6 100644 --- a/compiler/types/FamInstEnv.hs +++ b/compiler/types/FamInstEnv.hs @@ -221,10 +221,10 @@ pprFamInst famInst = hang (pprFamInstHdr famInst) 2 (ifPprDebug debug_stuff) where ax = fi_axiom famInst - debug_stuff = vcat [ ptext (sLit "Coercion axiom:") <+> ppr ax - , ptext (sLit "Tvs:") <+> ppr (fi_tvs famInst) - , ptext (sLit "LHS:") <+> ppr (fi_tys famInst) - , ptext (sLit "RHS:") <+> ppr (fi_rhs famInst) ] + debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax + , text "Tvs:" <+> ppr (fi_tvs famInst) + , text "LHS:" <+> ppr (fi_tys famInst) + , text "RHS:" <+> ppr (fi_rhs famInst) ] pprFamInstHdr :: FamInst -> SDoc pprFamInstHdr fi@(FamInst {fi_flavor = flavor}) @@ -234,7 +234,7 @@ pprFamInstHdr fi@(FamInst {fi_flavor = flavor}) -- For *top level* type instances, say "type instance T Int = blah" pp_instance | isTyConAssoc fam_tc = empty - | otherwise = ptext (sLit "instance") + | otherwise = text "instance" (fam_tc, etad_lhs_tys) = famInstSplitLHS fi vanilla_pp_head = pprTypeApp fam_tc etad_lhs_tys @@ -256,12 +256,12 @@ pprFamInstHdr fi@(FamInst {fi_flavor = flavor}) = vanilla_pp_head pprTyConSort = case flavor of - SynFamilyInst -> ptext (sLit "type") + SynFamilyInst -> text "type" DataFamilyInst tycon - | isDataTyCon tycon -> ptext (sLit "data") - | isNewTyCon tycon -> ptext (sLit "newtype") - | isAbstractTyCon tycon -> ptext (sLit "data") - | otherwise -> ptext (sLit "WEIRD") <+> ppr tycon + | isDataTyCon tycon -> text "data" + | isNewTyCon tycon -> text "newtype" + | isAbstractTyCon tycon -> text "data" + | otherwise -> text "WEIRD" <+> ppr tycon pprFamInsts :: [FamInst] -> SDoc pprFamInsts finsts = vcat (map pprFamInst finsts) @@ -371,7 +371,7 @@ newtype FamilyInstEnv = FamIE [FamInst] -- The instances for a particular family, in any order instance Outputable FamilyInstEnv where - ppr (FamIE fs) = ptext (sLit "FamIE") <+> vcat (map ppr fs) + ppr (FamIE fs) = text "FamIE" <+> vcat (map ppr fs) -- INVARIANTS: -- * The fs_tvs are distinct in each FamInst @@ -705,7 +705,7 @@ instance Outputable FamInstMatch where ppr (FamInstMatch { fim_instance = inst , fim_tys = tys , fim_cos = cos }) - = ptext (sLit "match with") <+> parens (ppr inst) <+> ppr tys <+> ppr cos + = text "match with" <+> parens (ppr inst) <+> ppr tys <+> ppr cos lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst] lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs index 1d2f4590f7..226fefce61 100644 --- a/compiler/types/InstEnv.hs +++ b/compiler/types/InstEnv.hs @@ -43,7 +43,6 @@ import BasicTypes import UniqFM import Util import Id -import FastString import Data.Data ( Data, Typeable ) import Data.Maybe ( isJust, isNothing ) @@ -173,14 +172,14 @@ pprInstance :: ClsInst -> SDoc -- Prints the ClsInst as an instance declaration pprInstance ispec = hang (pprInstanceHdr ispec) - 2 (vcat [ ptext (sLit "--") <+> pprDefinedAt (getName ispec) + 2 (vcat [ text "--" <+> pprDefinedAt (getName ispec) , ifPprDebug (ppr (is_dfun ispec)) ]) -- * pprInstanceHdr is used in VStudio to populate the ClassView tree pprInstanceHdr :: ClsInst -> SDoc -- Prints the ClsInst as an instance declaration pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun }) - = ptext (sLit "instance") <+> ppr flag <+> pprSigmaType (idType dfun) + = text "instance" <+> ppr flag <+> pprSigmaType (idType dfun) pprInstances :: [ClsInst] -> SDoc pprInstances ispecs = vcat (map pprInstance ispecs) @@ -667,12 +666,13 @@ lookupUniqueInstEnv instEnv cls tys = case lookupInstEnv False instEnv cls tys of ([(inst, inst_tys)], _, _) | noFlexiVar -> Right (inst, inst_tys') - | otherwise -> Left $ ptext (sLit "flexible type variable:") <+> + | otherwise -> Left $ text "flexible type variable:" <+> (ppr $ mkTyConApp (classTyCon cls) tys) where inst_tys' = [ty | Just ty <- inst_tys] noFlexiVar = all isJust inst_tys - _other -> Left $ ptext (sLit "instance not found") <+> (ppr $ mkTyConApp (classTyCon cls) tys) + _other -> Left $ text "instance not found" <+> + (ppr $ mkTyConApp (classTyCon cls) tys) lookupInstEnv' :: InstEnv -- InstEnv to look in -> VisibleOrphanModules -- But filter against this diff --git a/compiler/types/OptCoercion.hs b/compiler/types/OptCoercion.hs index 1038851d80..8e7a08d6d9 100644 --- a/compiler/types/OptCoercion.hs +++ b/compiler/types/OptCoercion.hs @@ -23,7 +23,6 @@ import Outputable import FamInstEnv ( flattenTys ) import Pair import ListSetOps ( getNth ) -import FastString import Util import Unify import InstEnv @@ -214,7 +213,7 @@ opt_co4 env sym rep r (CoVarCo cv) = ASSERT( isCoVar cv1 ) wrapRole rep r $ wrapSym sym (CoVarCo cv1) -- cv1 might have a substituted kind! - | otherwise = WARN( True, ptext (sLit "opt_co: not in scope:") <+> ppr cv $$ ppr env) + | otherwise = WARN( True, text "opt_co: not in scope:" <+> ppr cv $$ ppr env) ASSERT( isCoVar cv ) wrapRole rep r $ wrapSym sym (CoVarCo cv) diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index 0013b0523a..c0fc5fe240 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -1340,12 +1340,12 @@ pprTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing)) pprTyThingCategory :: TyThing -> SDoc pprTyThingCategory (ATyCon tc) - | isClassTyCon tc = ptext (sLit "Class") - | otherwise = ptext (sLit "Type constructor") -pprTyThingCategory (ACoAxiom _) = ptext (sLit "Coercion axiom") -pprTyThingCategory (AnId _) = ptext (sLit "Identifier") -pprTyThingCategory (AConLike (RealDataCon _)) = ptext (sLit "Data constructor") -pprTyThingCategory (AConLike (PatSynCon _)) = ptext (sLit "Pattern synonym") + | isClassTyCon tc = text "Class" + | otherwise = text "Type constructor" +pprTyThingCategory (ACoAxiom _) = text "Coercion axiom" +pprTyThingCategory (AnId _) = text "Identifier" +pprTyThingCategory (AConLike (RealDataCon _)) = text "Data constructor" +pprTyThingCategory (AConLike (PatSynCon _)) = text "Pattern synonym" instance NamedThing TyThing where -- Can't put this with the type @@ -1553,7 +1553,7 @@ extendSubstEnvs (tenv, cenv) v ty | CoercionTy co <- ty = (tenv, extendVarEnv cenv v co) | otherwise - = pprPanic "extendSubstEnvs" (ppr v <+> ptext (sLit "|->") <+> ppr ty) + = pprPanic "extendSubstEnvs" (ppr v <+> text "|->" <+> ppr ty) extendTCvSubst :: TCvSubst -> Var -> Type -> TCvSubst extendTCvSubst (TCvSubst in_scope tenv cenv) tv ty @@ -1682,10 +1682,10 @@ zipCoEnv cvs cos = mkVarEnv (zipEqual "zipCoEnv" cvs cos) instance Outputable TCvSubst where ppr (TCvSubst ins tenv cenv) - = brackets $ sep[ ptext (sLit "TCvSubst"), - nest 2 (ptext (sLit "In scope:") <+> ppr ins), - nest 2 (ptext (sLit "Type env:") <+> ppr tenv), - nest 2 (ptext (sLit "Co env:") <+> ppr cenv) ] + = brackets $ sep[ text "TCvSubst", + nest 2 (text "In scope:" <+> ppr ins), + nest 2 (text "Type env:" <+> ppr tenv), + nest 2 (text "Co env:" <+> ppr cenv) ] {- %************************************************************************ @@ -2143,7 +2143,7 @@ ppr_type p (AppTy t1 t2) ppr_type p (CastTy ty co) = if_print_coercions - (parens (ppr_type TopPrec ty <+> ptext (sLit "|>") <+> ppr co)) + (parens (ppr_type TopPrec ty <+> text "|>" <+> ppr co)) (ppr_type p ty) ppr_type _ (CoercionTy co) @@ -2301,8 +2301,8 @@ instance Outputable VisibilityFlag where instance Outputable Coercion where -- defined here to avoid orphans ppr = pprCo instance Outputable LeftOrRight where - ppr CLeft = ptext (sLit "Left") - ppr CRight = ptext (sLit "Right") + ppr CLeft = text "Left" + ppr CRight = text "Right" {- Note [When to print foralls] @@ -2370,7 +2370,7 @@ pprTyTcApp p tc tys | tc `hasKey` ipClassKey , [LitTy (StrTyLit n),ty] <- tys = maybeParen p FunPrec $ - char '?' <> ftext n <> ptext (sLit "::") <> ppr_type TopPrec ty + char '?' <> ftext n <> text "::" <> ppr_type TopPrec ty | tc `hasKey` consDataConKey , [_kind,ty1,ty2] <- tys @@ -2435,9 +2435,9 @@ pprTupleApp :: TyPrec -> (TyPrec -> a -> SDoc) pprTupleApp p pp tc sort tys | null tys , ConstraintTuple <- sort - = if opt_PprStyle_Debug then ptext (sLit "(%%)") + = if opt_PprStyle_Debug then text "(%%)" else maybeParen p FunPrec $ - ptext (sLit "() :: Constraint") + text "() :: Constraint" | otherwise = pprPromotionQuote tc <> tupleParens sort (pprWithCommas (pp TopPrec) tys) diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index 3dcc3d79a5..94da5f1349 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -1087,8 +1087,8 @@ data RepType = UbxTupleRep [UnaryType] -- INVARIANT: never an empty list (see No | UnaryRep UnaryType instance Outputable RepType where - ppr (UbxTupleRep tys) = ptext (sLit "UbxTupleRep") <+> ppr tys - ppr (UnaryRep ty) = ptext (sLit "UnaryRep") <+> ppr ty + ppr (UbxTupleRep tys) = text "UbxTupleRep" <+> ppr tys + ppr (UnaryRep ty) = text "UnaryRep" <+> ppr ty flattenRepType :: RepType -> [UnaryType] flattenRepType (UbxTupleRep tys) = tys diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 35a59c6409..1abb1c5b81 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -515,7 +515,7 @@ brackets d = SDoc $ Pretty.brackets . runSDoc d quote d = SDoc $ Pretty.quote . runSDoc d doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d angleBrackets d = char '<' <> d <> char '>' -paBrackets d = ptext (sLit "[:") <> d <> ptext (sLit ":]") +paBrackets d = text "[:" <> d <> text ":]" cparen :: Bool -> SDoc -> SDoc cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d @@ -539,15 +539,15 @@ semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc -blankLine = docToSDoc $ Pretty.ptext (sLit "") -dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.ptext (sLit "::")) -arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.ptext (sLit "->")) -larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.ptext (sLit "<-")) -darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.ptext (sLit "=>")) -arrowt = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.ptext (sLit ">-")) -larrowt = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.ptext (sLit "-<")) -arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.ptext (sLit ">>-")) -larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.ptext (sLit "-<<")) +blankLine = docToSDoc $ Pretty.text "" +dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::") +arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->") +larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.text "<-") +darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.text "=>") +arrowt = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-") +larrowt = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<") +arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-") +larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<") semi = docToSDoc $ Pretty.semi comma = docToSDoc $ Pretty.comma colon = docToSDoc $ Pretty.colon @@ -564,7 +564,7 @@ lbrace = docToSDoc $ Pretty.lbrace rbrace = docToSDoc $ Pretty.rbrace forAllLit :: SDoc -forAllLit = unicodeSyntax (char '∀') (ptext (sLit "forall")) +forAllLit = unicodeSyntax (char '∀') (text "forall") unicodeSyntax :: SDoc -> SDoc -> SDoc unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags -> @@ -705,8 +705,8 @@ instance Outputable Char where ppr c = text [c] instance Outputable Bool where - ppr True = ptext (sLit "True") - ppr False = ptext (sLit "False") + ppr True = text "True" + ppr False = text "False" instance Outputable Ordering where ppr LT = text "LT" @@ -744,12 +744,12 @@ instance (Outputable a, Outputable b) => Outputable (a, b) where ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) instance Outputable a => Outputable (Maybe a) where - ppr Nothing = ptext (sLit "Nothing") - ppr (Just x) = ptext (sLit "Just") <+> ppr x + ppr Nothing = text "Nothing" + ppr (Just x) = text "Just" <+> ppr x instance (Outputable a, Outputable b) => Outputable (Either a b) where - ppr (Left x) = ptext (sLit "Left") <+> ppr x - ppr (Right y) = ptext (sLit "Right") <+> ppr y + ppr (Left x) = text "Left" <+> ppr x + ppr (Right y) = text "Right" <+> ppr y -- ToDo: may not be used instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where @@ -813,7 +813,7 @@ instance Outputable a => Outputable (SCC a) where ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) instance Outputable Serialized where - ppr (Serialized the_type bytes) = int (length bytes) <+> ptext (sLit "of type") <+> text (show the_type) + ppr (Serialized the_type bytes) = int (length bytes) <+> text "of type" <+> text (show the_type) {- ************************************************************************ @@ -939,12 +939,12 @@ quotedList xs = hsep (punctuate comma (map quotes xs)) quotedListWithOr :: [SDoc] -> SDoc -- [x,y,z] ==> `x', `y' or `z' -quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs) +quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> text "or" <+> quotes (last xs) quotedListWithOr xs = quotedList xs quotedListWithNor :: [SDoc] -> SDoc -- [x,y,z] ==> `x', `y' nor `z' -quotedListWithNor xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "nor") <+> quotes (last xs) +quotedListWithNor xs@(_:_:_) = quotedList (init xs) <+> text "nor" <+> quotes (last xs) quotedListWithNor xs = quotedList xs {- @@ -965,7 +965,7 @@ intWithCommas n (q,r) = n `quotRem` 1000 zeroes | r >= 100 = empty | r >= 10 = char '0' - | otherwise = ptext (sLit "00") + | otherwise = text "00" -- | Converts an integer to a verbal index: -- @@ -973,12 +973,12 @@ intWithCommas n -- > speakNth 5 = text "fifth" -- > speakNth 21 = text "21st" speakNth :: Int -> SDoc -speakNth 1 = ptext (sLit "first") -speakNth 2 = ptext (sLit "second") -speakNth 3 = ptext (sLit "third") -speakNth 4 = ptext (sLit "fourth") -speakNth 5 = ptext (sLit "fifth") -speakNth 6 = ptext (sLit "sixth") +speakNth 1 = text "first" +speakNth 2 = text "second" +speakNth 3 = text "third" +speakNth 4 = text "fourth" +speakNth 5 = text "fifth" +speakNth 6 = text "sixth" speakNth n = hcat [ int n, text suffix ] where suffix | n <= 20 = "th" -- 11,12,13 are non-std @@ -995,13 +995,13 @@ speakNth n = hcat [ int n, text suffix ] -- > speakN 5 = text "five" -- > speakN 10 = text "10" speakN :: Int -> SDoc -speakN 0 = ptext (sLit "none") -- E.g. "he has none" -speakN 1 = ptext (sLit "one") -- E.g. "he has one" -speakN 2 = ptext (sLit "two") -speakN 3 = ptext (sLit "three") -speakN 4 = ptext (sLit "four") -speakN 5 = ptext (sLit "five") -speakN 6 = ptext (sLit "six") +speakN 0 = text "none" -- E.g. "he has none" +speakN 1 = text "one" -- E.g. "he has one" +speakN 2 = text "two" +speakN 3 = text "three" +speakN 4 = text "four" +speakN 5 = text "five" +speakN 6 = text "six" speakN n = int n -- | Converts an integer and object description to a statement about the @@ -1011,8 +1011,8 @@ speakN n = int n -- > speakNOf 1 (text "melon") = text "one melon" -- > speakNOf 3 (text "melon") = text "three melons" speakNOf :: Int -> SDoc -> SDoc -speakNOf 0 d = ptext (sLit "no") <+> d <> char 's' -speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument" +speakNOf 0 d = text "no" <+> d <> char 's' +speakNOf 1 d = text "one" <+> d -- E.g. "one argument" speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments" -- | Determines the pluralisation suffix appropriate for the length of a list: @@ -1026,21 +1026,21 @@ plural _ = char 's' -- | Determines the form of to be appropriate for the length of a list: -- --- > isOrAre [] = ptext (sLit "are") --- > isOrAre ["Hello"] = ptext (sLit "is") --- > isOrAre ["Hello", "World"] = ptext (sLit "are") +-- > isOrAre [] = text "are" +-- > isOrAre ["Hello"] = text "is" +-- > isOrAre ["Hello", "World"] = text "are" isOrAre :: [a] -> SDoc -isOrAre [_] = ptext (sLit "is") -isOrAre _ = ptext (sLit "are") +isOrAre [_] = text "is" +isOrAre _ = text "are" -- | Determines the form of to do appropriate for the length of a list: -- --- > doOrDoes [] = ptext (sLit "do") --- > doOrDoes ["Hello"] = ptext (sLit "does") --- > doOrDoes ["Hello", "World"] = ptext (sLit "do") +-- > doOrDoes [] = text "do" +-- > doOrDoes ["Hello"] = text "does" +-- > doOrDoes ["Hello", "World"] = text "do" doOrDoes :: [a] -> SDoc -doOrDoes [_] = ptext (sLit "does") -doOrDoes _ = ptext (sLit "do") +doOrDoes [_] = text "does" +doOrDoes _ = text "do" {- ************************************************************************ diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs index e5424f2c5d..c41e00469b 100644 --- a/compiler/utils/UniqDFM.hs +++ b/compiler/utils/UniqDFM.hs @@ -51,7 +51,6 @@ module UniqDFM ( alwaysUnsafeUfmToUdfm, ) where -import FastString import Unique ( Uniquable(..), Unique, getKey ) import Outputable @@ -297,5 +296,5 @@ instance Outputable a => Outputable (UniqDFM a) where pprUniqDFM :: (a -> SDoc) -> UniqDFM a -> SDoc pprUniqDFM ppr_elt ufm = brackets $ fsep $ punctuate comma $ - [ ppr uq <+> ptext (sLit ":->") <+> ppr_elt elt + [ ppr uq <+> text ":->" <+> ppr_elt elt | (uq, elt) <- udfmToList ufm ] diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs index 1dc6cf5655..9d8669ba04 100644 --- a/compiler/utils/UniqFM.hs +++ b/compiler/utils/UniqFM.hs @@ -69,7 +69,6 @@ module UniqFM ( joinUFM, pprUniqFM ) where -import FastString import Unique ( Uniquable(..), Unique, getKey ) import Outputable @@ -320,5 +319,5 @@ instance Outputable a => Outputable (UniqFM a) where pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc pprUniqFM ppr_elt ufm = brackets $ fsep $ punctuate comma $ - [ ppr uq <+> ptext (sLit ":->") <+> ppr_elt elt + [ ppr uq <+> text ":->" <+> ppr_elt elt | (uq, elt) <- ufmToList ufm ] diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs index 21de8dcb8b..69e00a0411 100644 --- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs +++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs @@ -226,7 +226,7 @@ externalClass fs = do { tycon <- dsLookupDPHRdrEnv (mkClsOccFS fs) >>= dsLookupTyCon ; case tyConClass_maybe tycon of Nothing -> pprPanic "Vectorise.Builtins.Initialise" $ - ptext (sLit "Data.Array.Parallel.Prim.") <> - ftext fs <+> ptext (sLit "is not a type class") + text "Data.Array.Parallel.Prim." <> + ftext fs <+> text "is not a type class" Just cls -> return cls } diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index fd1db9a7f8..5f283c6d3a 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -592,7 +592,7 @@ vectDictExpr (Case e bndr ty alts) -- vectDictAltCon (DataAlt datacon) = DataAlt <$> maybeV dataConErr (lookupDataCon datacon) where - dataConErr = ptext (sLit "Cannot vectorise data constructor:") <+> ppr datacon + dataConErr = text "Cannot vectorise data constructor:" <+> ppr datacon vectDictAltCon (LitAlt lit) = return $ LitAlt lit vectDictAltCon DEFAULT = return DEFAULT vectDictExpr (Let bnd body) @@ -637,7 +637,8 @@ mkScalarFun arg_tys res_ty expr ; return (vExpr, unused) } | otherwise - = do { traceVt "mkScalarFun: " $ ppr expr $$ ptext (sLit " ::") <+> ppr (mkFunTys arg_tys res_ty) + = do { traceVt "mkScalarFun: " $ ppr expr $$ text " ::" <+> + ppr (mkFunTys arg_tys res_ty) ; fn_var <- hoistExpr (fsLit "fn") expr DontInline ; zipf <- zipScalars arg_tys res_ty diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs index 2ad0059596..0d3e0c0c91 100644 --- a/compiler/vectorise/Vectorise/Monad/Global.hs +++ b/compiler/vectorise/Vectorise/Monad/Global.hs @@ -47,7 +47,6 @@ import Name import VarEnv import VarSet import Var as Var -import FastString import Outputable @@ -100,11 +99,11 @@ defGlobalVar v v' } where moduleOf var var' | var == var' - = ptext (sLit "vectorises to itself") + = text "vectorises to itself" | Just mod <- nameModule_maybe (Var.varName var') - = ptext (sLit "in module") <+> ppr mod + = text "in module" <+> ppr mod | otherwise - = ptext (sLit "in the current module") + = text "in the current module" -- |Remove the mapping of a variable in the vectorisation map. -- @@ -180,11 +179,11 @@ defTyConName tc nameOfTc' tc' } where moduleOf tc tc' | tc == tc' - = ptext (sLit "vectorises to itself") + = text "vectorises to itself" | Just mod <- nameModule_maybe (tyConName tc') - = ptext (sLit "in module") <+> ppr mod + = text "in module" <+> ppr mod | otherwise - = ptext (sLit "in the current module") + = text "in the current module" -- |Add a mapping between plain and vectorised `TyCon`s to the global environment. -- diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index e4b538ac34..7b00a5c1ef 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -232,8 +232,9 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls ; traceVt " convert : " $ ppr conv_tcs -- warn the user about unvectorised type constructors - ; let explanation = ptext (sLit "(They use unsupported language extensions") $$ - ptext (sLit "or depend on type constructors that are not vectorised)") + ; let explanation = text "(They use unsupported language extensions" + $$ text "or depend on type constructors that are" <+> + text "not vectorised)" drop_tcs_nosyn = filter (not . isTypeFamilyTyCon) . filter (not . isTypeSynonymTyCon) $ drop_tcs ; unless (null drop_tcs_nosyn) $ |