summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Iteration.hs2
-rw-r--r--compiler/GHC/Core/Opt/WorkWrap.hs6
-rw-r--r--compiler/GHC/Hs/Binds.hs4
-rw-r--r--compiler/GHC/Hs/Decls.hs4
-rw-r--r--compiler/GHC/Hs/Dump.hs4
-rw-r--r--compiler/GHC/Hs/Expr.hs4
-rw-r--r--compiler/GHC/Hs/ImpExp.hs2
-rw-r--r--compiler/GHC/Parser/Lexer.x76
-rw-r--r--compiler/GHC/Parser/PostProcess.hs5
-rw-r--r--compiler/GHC/ThToHs.hs42
-rw-r--r--compiler/GHC/Types/Basic.hs2
-rw-r--r--compiler/GHC/Types/SourceText.hs28
-rw-r--r--compiler/GHC/Unit/Module/Warnings.hs4
-rw-r--r--testsuite/tests/ghc-api/annotations-literals/parsed.hs25
-rw-r--r--utils/check-exact/ExactPrint.hs26
15 files changed, 123 insertions, 111 deletions
diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
index 1ecfa632e1..5a6644fd3e 100644
--- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
@@ -668,7 +668,7 @@ tryCastWorkerWrapper env _ _ _ bndr rhs -- All other bindings
mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma
-- See Note [Cast worker/wrapper]
mkCastWrapperInlinePrag (InlinePragma { inl_inline = fn_inl, inl_act = fn_act, inl_rule = rule_info })
- = InlinePragma { inl_src = SourceText "{-# INLINE"
+ = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE"
, inl_inline = fn_inl -- See Note [Worker/wrapper for INLINABLE functions]
, inl_sat = Nothing -- in GHC.Core.Opt.WorkWrap
, inl_act = wrap_act -- See Note [Wrapper activation]
diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs
index 29f1e3973f..061f98f1bc 100644
--- a/compiler/GHC/Core/Opt/WorkWrap.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap.hs
@@ -20,6 +20,8 @@ import GHC.Core.Type
import GHC.Core.Opt.WorkWrap.Utils
import GHC.Core.SimpleOpt
+import GHC.Data.FastString
+
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.Id.Info
@@ -819,7 +821,7 @@ mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div
NoInline _ -> inl_act fn_inl_prag
_ -> inl_act wrap_prag
- work_prag = InlinePragma { inl_src = SourceText "{-# INLINE"
+ work_prag = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE"
, inl_inline = fn_inline_spec
, inl_sat = Nothing
, inl_act = work_act
@@ -887,7 +889,7 @@ mkStrWrapperInlinePrag :: InlinePragma -> [CoreRule] -> InlinePragma
mkStrWrapperInlinePrag (InlinePragma { inl_inline = fn_inl
, inl_act = fn_act
, inl_rule = rule_info }) rules
- = InlinePragma { inl_src = SourceText "{-# INLINE"
+ = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE"
, inl_sat = Nothing
, inl_inline = fn_inl
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index c7dd8fca0f..ca4b6b08e2 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -756,7 +756,7 @@ ppr_sig (InlineSig _ var inl)
= ppr_pfx <+> pprInline inl <+> pprPrefixOcc (unLoc var) <+> text "#-}"
where
ppr_pfx = case inlinePragmaSource inl of
- SourceText src -> text src
+ SourceText src -> ftext src
NoSourceText -> text "{-#" <+> inlinePragmaName (inl_inline inl)
ppr_sig (SpecInstSig (_, src) ty)
= pragSrcBrackets src "{-# pragma" (text "instance" <+> ppr ty)
@@ -828,7 +828,7 @@ pragBrackets doc = text "{-#" <+> doc <+> text "#-}"
-- | Using SourceText in case the pragma was spelled differently or used mixed
-- case
pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc
-pragSrcBrackets (SourceText src) _ doc = text src <+> doc <+> text "#-}"
+pragSrcBrackets (SourceText src) _ doc = ftext src <+> doc <+> text "#-}"
pragSrcBrackets NoSourceText alt doc = text alt <+> doc <+> text "#-}"
pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 201adc5467..07bcba6cc4 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -913,7 +913,7 @@ ppOverlapPragma mb =
Just (L _ (Incoherent s)) -> maybe_stext s "{-# INCOHERENT #-}"
where
maybe_stext NoSourceText alt = text alt
- maybe_stext (SourceText src) _ = text src <+> text "#-}"
+ maybe_stext (SourceText src) _ = ftext src <+> text "#-}"
instance (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where
@@ -1219,7 +1219,7 @@ type instance XXWarnDecl (GhcPass _) = DataConCantHappen
instance OutputableBndrId p
=> Outputable (WarnDecls (GhcPass p)) where
ppr (Warnings ext decls)
- = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"
+ = ftext src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"
where src = case ghcPass @p of
GhcPs | (_, SourceText src) <- ext -> src
GhcRn | SourceText src <- ext -> src
diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs
index 794607bd49..245a1cd43e 100644
--- a/compiler/GHC/Hs/Dump.hs
+++ b/compiler/GHC/Hs/Dump.hs
@@ -139,8 +139,8 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
sourceText :: SourceText -> SDoc
sourceText NoSourceText = parens $ text "NoSourceText"
sourceText (SourceText src) = case bs of
- NoBlankSrcSpan -> parens $ text "SourceText" <+> text src
- BlankSrcSpanFile -> parens $ text "SourceText" <+> text src
+ NoBlankSrcSpan -> parens $ text "SourceText" <+> ftext src
+ BlankSrcSpanFile -> parens $ text "SourceText" <+> ftext src
_ -> parens $ text "SourceText" <+> text "blanked"
epaAnchor :: EpaLocation -> SDoc
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index be7af5002a..385bbd62c7 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -131,7 +131,7 @@ data SyntaxExprTc = SyntaxExprTc { syn_expr :: HsExpr GhcTc
-- | This is used for rebindable-syntax pieces that are too polymorphic
-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)
noExpr :: HsExpr (GhcPass p)
-noExpr = HsLit noComments (HsString (SourceText "noExpr") (fsLit "noExpr"))
+noExpr = HsLit noComments (HsString (SourceText $ fsLit "noExpr") (fsLit "noExpr"))
noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p)
-- Before renaming, and sometimes after
@@ -519,7 +519,7 @@ ppr_expr (HsRecSel _ f) = pprPrefixOcc f
ppr_expr (HsIPVar _ v) = ppr v
ppr_expr (HsOverLabel _ s l) = char '#' <> case s of
NoSourceText -> ppr l
- SourceText src -> text src
+ SourceText src -> ftext src
ppr_expr (HsLit _ lit) = ppr lit
ppr_expr (HsOverLit _ lit) = ppr lit
ppr_expr (HsPar _ _ e _) = parens (ppr_lexpr e)
diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs
index 83f5cfbb88..06a6cc783e 100644
--- a/compiler/GHC/Hs/ImpExp.hs
+++ b/compiler/GHC/Hs/ImpExp.hs
@@ -171,7 +171,7 @@ instance (OutputableBndrId p
GhcTc -> dataConCantHappen ext
in case mSrcText of
NoSourceText -> text "{-# SOURCE #-}"
- SourceText src -> text src <+> text "#-}"
+ SourceText src -> ftext src <+> text "#-}"
ppr_imp _ NotBoot = empty
pp_spec Nothing = empty
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index 48a1a367c2..61235f5942 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -42,6 +42,7 @@
{
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE UnboxedTuples #-}
@@ -1215,7 +1216,7 @@ skip_one_varid f span buf len _buf2
skip_one_varid_src :: (SourceText -> FastString -> Token) -> Action
skip_one_varid_src f span buf len _buf2
- = return (L span $! f (SourceText $ lexemeToString (stepOn buf) (len-1))
+ = return (L span $! f (SourceText $ lexemeToFastString (stepOn buf) (len-1))
(lexemeToFastString (stepOn buf) (len-1)))
skip_two_varid :: (FastString -> Token) -> Action
@@ -1226,6 +1227,10 @@ strtoken :: (String -> Token) -> Action
strtoken f span buf len _buf2 =
return (L span $! (f $! lexemeToString buf len))
+fstrtoken :: (FastString -> Token) -> Action
+fstrtoken f span buf len _buf2 =
+ return (L span $! (f $! lexemeToFastString buf len))
+
begin :: Int -> Action
begin code _span _str _len _buf2 = do pushLexState code; lexToken
@@ -1620,7 +1625,7 @@ mkHdkCommentSection loc n mkDS = (HdkCommentSection n ds, ITdocComment ds loc)
rulePrag :: Action
rulePrag span buf len _buf2 = do
setExts (.|. xbit InRulePragBit)
- let !src = lexemeToString buf len
+ let !src = lexemeToFastString buf len
return (L span (ITrules_prag (SourceText src)))
-- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead
@@ -1630,7 +1635,7 @@ linePrag span buf len buf2 = do
usePosPrags <- getBit UsePosPragsBit
if usePosPrags
then begin line_prag2 span buf len buf2
- else let !src = lexemeToString buf len
+ else let !src = lexemeToFastString buf len
in return (L span (ITline_prag (SourceText src)))
-- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead
@@ -1638,10 +1643,9 @@ linePrag span buf len buf2 = do
columnPrag :: Action
columnPrag span buf len buf2 = do
usePosPrags <- getBit UsePosPragsBit
- let !src = lexemeToString buf len
if usePosPrags
then begin column_prag span buf len buf2
- else let !src = lexemeToString buf len
+ else let !src = lexemeToFastString buf len
in return (L span (ITcolumn_prag (SourceText src)))
endPrag :: Action
@@ -1888,8 +1892,8 @@ tok_integral :: (SourceText -> Integer -> Token)
-> Action
tok_integral itint transint transbuf translen (radix,char_to_int) span buf len _buf2 = do
numericUnderscores <- getBit NumericUnderscoresBit -- #14473
- let src = lexemeToString buf len
- when ((not numericUnderscores) && ('_' `elem` src)) $ do
+ let src = lexemeToFastString buf len
+ when ((not numericUnderscores) && ('_' `elem` unpackFS src)) $ do
pState <- getPState
let msg = PsErrNumUnderscores NumUnderscore_Integral
addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg
@@ -1901,7 +1905,7 @@ tok_num :: (Integer -> Integer)
-> Int -> Int
-> (Integer, (Char->Int)) -> Action
tok_num = tok_integral $ \case
- st@(SourceText ('-':_)) -> itint st (const True)
+ st@(SourceText (unconsFS -> Just ('-',_))) -> itint st (const True)
st@(SourceText _) -> itint st (const False)
st@NoSourceText -> itint st (< 0)
where
@@ -2165,7 +2169,7 @@ lex_string_tok span buf _len _buf2 = do
tok = case lexed of
LexedPrimString s -> ITprimstring (SourceText src) (unsafeMkByteString s)
LexedRegularString s -> ITstring (SourceText src) (mkFastString s)
- src = lexemeToString buf (cur bufEnd - cur buf)
+ src = lexemeToFastString buf (cur bufEnd - cur buf)
return $ L (mkPsSpan (psSpanStart span) end) tok
@@ -2176,7 +2180,7 @@ lex_quoted_label span buf _len _buf2 = do
(AI end bufEnd) <- getInput
let
token = ITlabelvarid (SourceText src) (mkFastString s)
- src = lexemeToString (stepOn buf) (cur bufEnd - cur buf - 1)
+ src = lexemeToFastString (stepOn buf) (cur bufEnd - cur buf - 1)
start = psSpanStart span
return $ L (mkPsSpan start end) token
@@ -2301,13 +2305,13 @@ finish_char_tok buf loc ch -- We've already seen the closing quote
-- Just need to check for trailing #
= do magicHash <- getBit MagicHashBit
i@(AI end bufEnd) <- getInput
- let src = lexemeToString buf (cur bufEnd - cur buf)
+ let src = lexemeToFastString buf (cur bufEnd - cur buf)
if magicHash then do
case alexGetChar' i of
Just ('#',i@(AI end bufEnd')) -> do
setInput i
-- Include the trailing # in SourceText
- let src' = lexemeToString buf (cur bufEnd' - cur buf)
+ let src' = lexemeToFastString buf (cur bufEnd' - cur buf)
return (L (mkPsSpan loc end)
(ITprimchar (SourceText src') ch))
_other ->
@@ -3691,42 +3695,42 @@ ignoredPrags = Map.fromList (map ignored pragmas)
oneWordPrags = Map.fromList [
("rules", rulePrag),
("inline",
- strtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) FunLike))),
+ fstrtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) FunLike))),
("inlinable",
- strtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),
+ fstrtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),
("inlineable",
- strtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),
+ fstrtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))),
-- Spelling variant
("notinline",
- strtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) FunLike))),
- ("opaque", strtoken (\s -> ITopaque_prag (SourceText s))),
- ("specialize", strtoken (\s -> ITspec_prag (SourceText s))),
- ("source", strtoken (\s -> ITsource_prag (SourceText s))),
- ("warning", strtoken (\s -> ITwarning_prag (SourceText s))),
- ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))),
- ("scc", strtoken (\s -> ITscc_prag (SourceText s))),
- ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))),
- ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))),
- ("ann", strtoken (\s -> ITann_prag (SourceText s))),
- ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))),
- ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))),
- ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))),
- ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))),
- ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))),
- ("ctype", strtoken (\s -> ITctype (SourceText s))),
- ("complete", strtoken (\s -> ITcomplete_prag (SourceText s))),
+ fstrtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) FunLike))),
+ ("opaque", fstrtoken (\s -> ITopaque_prag (SourceText s))),
+ ("specialize", fstrtoken (\s -> ITspec_prag (SourceText s))),
+ ("source", fstrtoken (\s -> ITsource_prag (SourceText s))),
+ ("warning", fstrtoken (\s -> ITwarning_prag (SourceText s))),
+ ("deprecated", fstrtoken (\s -> ITdeprecated_prag (SourceText s))),
+ ("scc", fstrtoken (\s -> ITscc_prag (SourceText s))),
+ ("unpack", fstrtoken (\s -> ITunpack_prag (SourceText s))),
+ ("nounpack", fstrtoken (\s -> ITnounpack_prag (SourceText s))),
+ ("ann", fstrtoken (\s -> ITann_prag (SourceText s))),
+ ("minimal", fstrtoken (\s -> ITminimal_prag (SourceText s))),
+ ("overlaps", fstrtoken (\s -> IToverlaps_prag (SourceText s))),
+ ("overlappable", fstrtoken (\s -> IToverlappable_prag (SourceText s))),
+ ("overlapping", fstrtoken (\s -> IToverlapping_prag (SourceText s))),
+ ("incoherent", fstrtoken (\s -> ITincoherent_prag (SourceText s))),
+ ("ctype", fstrtoken (\s -> ITctype (SourceText s))),
+ ("complete", fstrtoken (\s -> ITcomplete_prag (SourceText s))),
("column", columnPrag)
]
twoWordPrags = Map.fromList [
("inline conlike",
- strtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) ConLike))),
+ fstrtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) ConLike))),
("notinline conlike",
- strtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) ConLike))),
+ fstrtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) ConLike))),
("specialize inline",
- strtoken (\s -> (ITspec_inline_prag (SourceText s) True))),
+ fstrtoken (\s -> (ITspec_inline_prag (SourceText s) True))),
("specialize notinline",
- strtoken (\s -> (ITspec_inline_prag (SourceText s) False)))
+ fstrtoken (\s -> (ITspec_inline_prag (SourceText s) False)))
]
dispatch_pragmas :: Map String Action -> Action
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 0b7053dcbb..52251b211c 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -2717,7 +2717,8 @@ parseCImport cconv safety nm str sourceText =
((mk Nothing <$> cimp nm) +++
(do h <- munch1 hdr_char
skipSpaces
- mk (Just (Header (SourceText h) (mkFastString h)))
+ let src = mkFastString h
+ mk (Just (Header (SourceText src) src))
<$> cimp nm))
]
skipSpaces
@@ -3116,7 +3117,7 @@ mkLHsOpTy prom x op y =
in L loc (mkHsOpTy prom x op y)
mkMultTy :: LHsToken "%" GhcPs -> LHsType GhcPs -> LHsUniToken "->" "→" GhcPs -> HsArrow GhcPs
-mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1))) arr
+mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) arr
-- See #18888 for the use of (SourceText "1") above
= HsLinearArrow (HsPct1 (L locOfPct1 HsTok) arr)
where
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 39da7e0c51..a28b4767b5 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -331,10 +331,10 @@ cvtDec (InstanceD o ctxt ty decs)
where
overlap pragma =
case pragma of
- TH.Overlaps -> Hs.Overlaps (SourceText "OVERLAPS")
- TH.Overlappable -> Hs.Overlappable (SourceText "OVERLAPPABLE")
- TH.Overlapping -> Hs.Overlapping (SourceText "OVERLAPPING")
- TH.Incoherent -> Hs.Incoherent (SourceText "INCOHERENT")
+ TH.Overlaps -> Hs.Overlaps (SourceText $ fsLit "OVERLAPS")
+ TH.Overlappable -> Hs.Overlappable (SourceText $ fsLit "OVERLAPPABLE")
+ TH.Overlapping -> Hs.Overlapping (SourceText $ fsLit "OVERLAPPING")
+ TH.Incoherent -> Hs.Incoherent (SourceText $ fsLit "INCOHERENT")
@@ -803,8 +803,8 @@ cvtForD (ImportF callconv safety from nm ty) =
-- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess
| callconv == TH.Prim || callconv == TH.JavaScript
-> mk_imp (CImport (L l $ quotedSourceText from) (L l (cvt_conv callconv)) (L l safety') Nothing
- (CFunction (StaticTarget (SourceText from)
- (mkFastString from) Nothing
+ (CFunction (StaticTarget (SourceText fromtxt)
+ fromtxt Nothing
True)))
| Just impspec <- parseCImport (L l (cvt_conv callconv)) (L l safety')
(mkFastString (TH.nameBase nm))
@@ -813,6 +813,7 @@ cvtForD (ImportF callconv safety from nm ty) =
| otherwise
-> failWith $ InvalidCCallImpent from }
where
+ fromtxt = mkFastString from
mk_imp impspec
= do { nm' <- vNameN nm
; ty' <- cvtSigType ty
@@ -830,8 +831,9 @@ cvtForD (ExportF callconv as nm ty)
= do { nm' <- vNameN nm
; ty' <- cvtSigType ty
; l <- getL
- ; let e = CExport (L l (SourceText as)) (L l (CExportStatic (SourceText as)
- (mkFastString as)
+ ; let astxt = mkFastString as
+ ; let e = CExport (L l (SourceText astxt)) (L l (CExportStatic (SourceText astxt)
+ astxt
(cvt_conv callconv)))
; return $ ForeignExport { fd_e_ext = noAnn
, fd_name = nm'
@@ -856,9 +858,9 @@ cvtPragmaD (InlineP nm inline rm phases)
-- (e.g., `INLINE`d pattern synonyms, cf. #23203)
nm' <- vcNameN nm
; let dflt = dfltActivation inline
- ; let src TH.NoInline = "{-# NOINLINE"
- src TH.Inline = "{-# INLINE"
- src TH.Inlinable = "{-# INLINABLE"
+ ; let src TH.NoInline = fsLit "{-# NOINLINE"
+ src TH.Inline = fsLit "{-# INLINE"
+ src TH.Inlinable = fsLit "{-# INLINABLE"
; let ip = InlinePragma { inl_src = toSrcTxt inline
, inl_inline = cvtInline inline (toSrcTxt inline)
, inl_rule = cvtRuleMatch rm
@@ -876,20 +878,20 @@ cvtPragmaD (OpaqueP nm)
, inl_act = NeverActive
, inl_sat = Nothing }
where
- srcTxt = SourceText "{-# OPAQUE"
+ srcTxt = SourceText $ fsLit "{-# OPAQUE"
; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip }
cvtPragmaD (SpecialiseP nm ty inline phases)
= do { nm' <- vNameN nm
; ty' <- cvtSigType ty
- ; let src TH.NoInline = "{-# SPECIALISE NOINLINE"
- src TH.Inline = "{-# SPECIALISE INLINE"
- src TH.Inlinable = "{-# SPECIALISE INLINE"
+ ; let src TH.NoInline = fsLit "{-# SPECIALISE NOINLINE"
+ src TH.Inline = fsLit "{-# SPECIALISE INLINE"
+ src TH.Inlinable = fsLit "{-# SPECIALISE INLINE"
; let (inline', dflt, srcText) = case inline of
Just inline1 -> (cvtInline inline1 (toSrcTxt inline1), dfltActivation inline1,
toSrcTxt inline1)
Nothing -> (NoUserInlinePrag, AlwaysActive,
- SourceText "{-# SPECIALISE")
+ SourceText $ fsLit "{-# SPECIALISE")
where
toSrcTxt a = SourceText $ src a
; let ip = InlinePragma { inl_src = srcText
@@ -902,7 +904,7 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
cvtPragmaD (SpecialiseInstP ty)
= do { ty' <- cvtSigType ty
; returnJustLA $ Hs.SigD noExtField $
- SpecInstSig (noAnn, (SourceText "{-# SPECIALISE")) ty' }
+ SpecInstSig (noAnn, (SourceText $ fsLit "{-# SPECIALISE")) ty' }
cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
= do { let nm' = mkFastString nm
@@ -921,7 +923,7 @@ cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
, rd_lhs = lhs'
, rd_rhs = rhs' }
; returnJustLA $ Hs.RuleD noExtField
- $ HsRules { rds_ext = (noAnn, SourceText "{-# RULES")
+ $ HsRules { rds_ext = (noAnn, SourceText $ fsLit "{-# RULES")
, rds_rules = [rule] }
}
@@ -937,7 +939,7 @@ cvtPragmaD (AnnP target exp)
n' <- vcName n
wrapParLA ValueAnnProvenance n'
; returnJustLA $ Hs.AnnD noExtField
- $ HsAnnotation (noAnn, (SourceText "{-# ANN")) target' exp'
+ $ HsAnnotation (noAnn, (SourceText $ fsLit "{-# ANN")) target' exp'
}
-- NB: This is the only place in GHC.ThToHs that makes use of the `setL`
@@ -1405,7 +1407,7 @@ cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
-- "GHC.ThToHs", hence panic
quotedSourceText :: String -> SourceText
-quotedSourceText s = SourceText $ "\"" ++ s ++ "\""
+quotedSourceText s = SourceText $ fsLit $ "\"" ++ s ++ "\""
cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs]
cvtPats pats = mapM cvtPat pats
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index 1f73c82028..7c9db88e26 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/compiler/GHC/Types/Basic.hs
@@ -1560,7 +1560,7 @@ noUserInlineSpec _ = False
defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
:: InlinePragma
-defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE"
+defaultInlinePragma = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE"
, inl_act = AlwaysActive
, inl_rule = FunLike
, inl_inline = NoUserInlinePrag
diff --git a/compiler/GHC/Types/SourceText.hs b/compiler/GHC/Types/SourceText.hs
index 72c77dec95..5995308505 100644
--- a/compiler/GHC/Types/SourceText.hs
+++ b/compiler/GHC/Types/SourceText.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ViewPatterns #-}
-- | Source text
--
@@ -95,7 +96,7 @@ For OverLitVal
-- Note [Literal source text],[Pragma source text]
data SourceText
- = SourceText String
+ = SourceText FastString
| NoSourceText
-- ^ For when code is generated, e.g. TH,
-- deriving. The pretty printer will then make
@@ -103,7 +104,7 @@ data SourceText
deriving (Data, Show, Eq )
instance Outputable SourceText where
- ppr (SourceText s) = text "SourceText" <+> text s
+ ppr (SourceText s) = text "SourceText" <+> ftext s
ppr NoSourceText = text "NoSourceText"
instance Binary SourceText where
@@ -124,7 +125,7 @@ instance Binary SourceText where
-- | Special combinator for showing string literals.
pprWithSourceText :: SourceText -> SDoc -> SDoc
pprWithSourceText NoSourceText d = d
-pprWithSourceText (SourceText src) _ = text src
+pprWithSourceText (SourceText src) _ = ftext src
------------------------------------------------
-- Literals
@@ -143,7 +144,7 @@ data IntegralLit = IL
deriving (Data, Show)
mkIntegralLit :: Integral a => a -> IntegralLit
-mkIntegralLit i = IL { il_text = SourceText (show i_integer)
+mkIntegralLit i = IL { il_text = SourceText (fsLit $ show i_integer)
, il_neg = i < 0
, il_value = i_integer }
where
@@ -153,9 +154,9 @@ mkIntegralLit i = IL { il_text = SourceText (show i_integer)
negateIntegralLit :: IntegralLit -> IntegralLit
negateIntegralLit (IL text neg value)
= case text of
- SourceText ('-':src) -> IL (SourceText src) False (negate value)
- SourceText src -> IL (SourceText ('-':src)) True (negate value)
- NoSourceText -> IL NoSourceText (not neg) (negate value)
+ SourceText (unconsFS -> Just ('-',src)) -> IL (SourceText src) False (negate value)
+ SourceText src -> IL (SourceText ('-' `consFS` src)) True (negate value)
+ NoSourceText -> IL NoSourceText (not neg) (negate value)
-- | Fractional Literal
--
@@ -206,7 +207,7 @@ rationalFromFractionalLit (FL _ _ i e expBase) =
mkRationalWithExponentBase i e expBase
mkTHFractionalLit :: Rational -> FractionalLit
-mkTHFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double))
+mkTHFractionalLit r = FL { fl_text = SourceText (fsLit $ show (realToFrac r::Double))
-- Converting to a Double here may technically lose
-- precision (see #15502). We could alternatively
-- convert to a Rational for the most accuracy, but
@@ -222,13 +223,14 @@ mkTHFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double))
negateFractionalLit :: FractionalLit -> FractionalLit
negateFractionalLit (FL text neg i e eb)
= case text of
- SourceText ('-':src) -> FL (SourceText src) False (negate i) e eb
- SourceText src -> FL (SourceText ('-':src)) True (negate i) e eb
+ SourceText (unconsFS -> Just ('-',src))
+ -> FL (SourceText src) False (negate i) e eb
+ SourceText src -> FL (SourceText ('-' `consFS` src)) True (negate i) e eb
NoSourceText -> FL NoSourceText (not neg) (negate i) e eb
-- | The integer should already be negated if it's negative.
integralFractionalLit :: Bool -> Integer -> FractionalLit
-integralFractionalLit neg i = FL { fl_text = SourceText (show i)
+integralFractionalLit neg i = FL { fl_text = SourceText (fsLit $ show i)
, fl_neg = neg
, fl_signi = i :% 1
, fl_exp = 0
@@ -238,7 +240,7 @@ integralFractionalLit neg i = FL { fl_text = SourceText (show i)
mkSourceFractionalLit :: String -> Bool -> Integer -> Integer
-> FractionalExponentBase
-> FractionalLit
-mkSourceFractionalLit !str !b !r !i !ff = FL (SourceText str) b (r :% 1) i ff
+mkSourceFractionalLit !str !b !r !i !ff = FL (SourceText $ fsLit str) b (r :% 1) i ff
{- Note [fractional exponent bases]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -258,7 +260,7 @@ instance Ord IntegralLit where
compare = compare `on` il_value
instance Outputable IntegralLit where
- ppr (IL (SourceText src) _ _) = text src
+ ppr (IL (SourceText src) _ _) = ftext src
ppr (IL NoSourceText _ value) = text (show value)
diff --git a/compiler/GHC/Unit/Module/Warnings.hs b/compiler/GHC/Unit/Module/Warnings.hs
index 72f6586094..af07bf00cd 100644
--- a/compiler/GHC/Unit/Module/Warnings.hs
+++ b/compiler/GHC/Unit/Module/Warnings.hs
@@ -196,12 +196,12 @@ instance Outputable (WarningTxt pass) where
ppr (WarningTxt _ lsrc ws)
= case unLoc lsrc of
NoSourceText -> pp_ws ws
- SourceText src -> text src <+> pp_ws ws <+> text "#-}"
+ SourceText src -> ftext src <+> pp_ws ws <+> text "#-}"
ppr (DeprecatedTxt lsrc ds)
= case unLoc lsrc of
NoSourceText -> pp_ws ds
- SourceText src -> text src <+> pp_ws ds <+> text "#-}"
+ SourceText src -> ftext src <+> pp_ws ds <+> text "#-}"
instance Binary (WarningTxt GhcRn) where
put_ bh (WarningTxt c s w) = do
diff --git a/testsuite/tests/ghc-api/annotations-literals/parsed.hs b/testsuite/tests/ghc-api/annotations-literals/parsed.hs
index 06fa9ea60d..9e9ae93c29 100644
--- a/testsuite/tests/ghc-api/annotations-literals/parsed.hs
+++ b/testsuite/tests/ghc-api/annotations-literals/parsed.hs
@@ -3,6 +3,7 @@
-- argument.
module Main where
+import GHC.Data.FastString
import GHC.Types.Basic
import GHC.Types.SourceText
import Data.Data
@@ -46,32 +47,32 @@ testOneFile libdir fileName = do
doHsLit :: HsLit GhcPs -> [String]
doHsLit (HsChar (SourceText src) c)
- = ["HsChar [" ++ src ++ "] " ++ show c]
+ = ["HsChar [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsCharPrim (SourceText src) c)
- = ["HsCharPrim [" ++ src ++ "] " ++ show c]
+ = ["HsCharPrim [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsString (SourceText src) c)
- = ["HsString [" ++ src ++ "] " ++ show c]
+ = ["HsString [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsStringPrim (SourceText src) c)
- = ["HsStringPrim [" ++ src ++ "] " ++ show c]
+ = ["HsStringPrim [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsInt _ (IL (SourceText src) _ c))
- = ["HsInt [" ++ src ++ "] " ++ show c]
+ = ["HsInt [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsIntPrim (SourceText src) c)
- = ["HsIntPrim [" ++ src ++ "] " ++ show c]
+ = ["HsIntPrim [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsWordPrim (SourceText src) c)
- = ["HsWordPrim [" ++ src ++ "] " ++ show c]
+ = ["HsWordPrim [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsInt64Prim (SourceText src) c)
- = ["HsInt64Prim [" ++ src ++ "] " ++ show c]
+ = ["HsInt64Prim [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsWord64Prim (SourceText src) c)
- = ["HsWord64Prim [" ++ src ++ "] " ++ show c]
+ = ["HsWord64Prim [" ++ unpackFS src ++ "] " ++ show c]
doHsLit (HsInteger (SourceText src) c _)
- = ["HsInteger [" ++ src ++ "] " ++ show c]
+ = ["HsInteger [" ++ unpackFS src ++ "] " ++ show c]
doHsLit _ = []
doOverLit :: OverLitVal -> [String]
doOverLit (HsIntegral (IL (SourceText src) _ c))
- = ["HsIntegral [" ++ src ++ "] " ++ show c]
+ = ["HsIntegral [" ++ unpackFS src ++ "] " ++ show c]
doOverLit (HsIsString (SourceText src) c)
- = ["HsIsString [" ++ src ++ "] " ++ show c]
+ = ["HsIsString [" ++ unpackFS src ++ "] " ++ show c]
doOverLit _ = []
pp a = showPprUnsafe a
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index f4d4defb5b..97e35b0ebb 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -477,7 +477,7 @@ class (Typeable a) => ExactPrint a where
printSourceText :: (Monad m, Monoid w) => SourceText -> String -> EP w m ()
printSourceText (NoSourceText) txt = printStringAdvance txt >> return ()
-printSourceText (SourceText txt) _ = printStringAdvance txt >> return ()
+printSourceText (SourceText txt) _ = printStringAdvance (unpackFS txt) >> return ()
-- ---------------------------------------------------------------------
@@ -564,7 +564,7 @@ printStringAtAAC capture (EpaDelta d cs) s = do
markExternalSourceText :: (Monad m, Monoid w) => SrcSpan -> SourceText -> String -> EP w m ()
markExternalSourceText l NoSourceText txt = printStringAtRs (realSrcSpan l) txt >> return ()
-markExternalSourceText l (SourceText txt) _ = printStringAtRs (realSrcSpan l) txt >> return ()
+markExternalSourceText l (SourceText txt) _ = printStringAtRs (realSrcSpan l) (unpackFS txt) >> return ()
-- ---------------------------------------------------------------------
@@ -658,21 +658,21 @@ markAnnCloseP an = markEpAnnLMS' an lapr_close AnnClose (Just "#-}")
markAnnOpenP :: (Monad m, Monoid w) => EpAnn AnnPragma -> SourceText -> String -> EP w m (EpAnn AnnPragma)
markAnnOpenP an NoSourceText txt = markEpAnnLMS' an lapr_open AnnOpen (Just txt)
-markAnnOpenP an (SourceText txt) _ = markEpAnnLMS' an lapr_open AnnOpen (Just txt)
+markAnnOpenP an (SourceText txt) _ = markEpAnnLMS' an lapr_open AnnOpen (Just $ unpackFS txt)
markAnnOpen :: (Monad m, Monoid w) => EpAnn [AddEpAnn] -> SourceText -> String -> EP w m (EpAnn [AddEpAnn])
markAnnOpen an NoSourceText txt = markEpAnnLMS an lidl AnnOpen (Just txt)
-markAnnOpen an (SourceText txt) _ = markEpAnnLMS an lidl AnnOpen (Just txt)
+markAnnOpen an (SourceText txt) _ = markEpAnnLMS an lidl AnnOpen (Just $ unpackFS txt)
markAnnOpen' :: (Monad m, Monoid w)
=> Maybe EpaLocation -> SourceText -> String -> EP w m (Maybe EpaLocation)
markAnnOpen' ms NoSourceText txt = printStringAtMLoc' ms txt
-markAnnOpen' ms (SourceText txt) _ = printStringAtMLoc' ms txt
+markAnnOpen' ms (SourceText txt) _ = printStringAtMLoc' ms $ unpackFS txt
markAnnOpen'' :: (Monad m, Monoid w)
=> EpaLocation -> SourceText -> String -> EP w m EpaLocation
markAnnOpen'' el NoSourceText txt = printStringAtAA el txt
-markAnnOpen'' el (SourceText txt) _ = printStringAtAA el txt
+markAnnOpen'' el (SourceText txt) _ = printStringAtAA el $ unpackFS txt
-- ---------------------------------------------------------------------
{-
@@ -1795,7 +1795,7 @@ instance ExactPrint (RuleDecls GhcPs) where
an0 <-
case src of
NoSourceText -> markEpAnnLMS an lidl AnnOpen (Just "{-# RULES")
- SourceText srcTxt -> markEpAnnLMS an lidl AnnOpen (Just srcTxt)
+ SourceText srcTxt -> markEpAnnLMS an lidl AnnOpen (Just $ unpackFS srcTxt)
rules' <- markAnnotated rules
an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}")
return (HsRules (an1,src) rules')
@@ -2715,7 +2715,7 @@ instance ExactPrint (HsExpr GhcPs) where
printStringAtLsDelta (SameLine 0) "#"
case src of
NoSourceText -> printStringAtLsDelta (SameLine 0) (unpackFS l)
- SourceText txt -> printStringAtLsDelta (SameLine 0) txt
+ SourceText txt -> printStringAtLsDelta (SameLine 0) (unpackFS txt)
return x
exact x@(HsIPVar _ (HsIPName n))
@@ -2727,7 +2727,7 @@ instance ExactPrint (HsExpr GhcPs) where
HsFractional (FL { fl_text = src }) -> src
HsIsString src _ -> src
case str of
- SourceText s -> printStringAdvance s >> return ()
+ SourceText s -> printStringAdvance (unpackFS s) >> return ()
NoSourceText -> withPpr x >> return ()
return x
@@ -3909,7 +3909,7 @@ instance ExactPrint (HsType GhcPs) where
NoSourceText -> return an
SourceText src -> do
debugM $ "HsBangTy: src=" ++ showAst src
- an0 <- markEpAnnLMS an lid AnnOpen (Just src)
+ an0 <- markEpAnnLMS an lid AnnOpen (Just $ unpackFS src)
an1 <- markEpAnnLMS an0 lid AnnClose (Just "#-}")
debugM $ "HsBangTy: done unpackedness"
return an1
@@ -4678,7 +4678,7 @@ instance ExactPrint (HsOverLit GhcPs) where
HsIsString src _ -> src
in
case str of
- SourceText s -> printStringAdvance s >> return ol
+ SourceText s -> printStringAdvance (unpackFS s) >> return ol
NoSourceText -> return ol
-- ---------------------------------------------------------------------
@@ -4710,11 +4710,11 @@ hsLit2String lit =
toSourceTextWithSuffix :: (Show a) => SourceText -> a -> String -> String
toSourceTextWithSuffix (NoSourceText) alt suffix = show alt ++ suffix
-toSourceTextWithSuffix (SourceText txt) _alt suffix = txt ++ suffix
+toSourceTextWithSuffix (SourceText txt) _alt suffix = unpackFS txt ++ suffix
sourceTextToString :: SourceText -> String -> String
sourceTextToString NoSourceText alt = alt
-sourceTextToString (SourceText txt) _ = txt
+sourceTextToString (SourceText txt) _ = unpackFS txt
-- ---------------------------------------------------------------------
View Lorry Controller Status