diff options
-rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Iteration.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/WorkWrap.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Hs/Binds.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Hs/Decls.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Hs/Dump.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Hs/Expr.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Hs/ImpExp.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Parser/Lexer.x | 76 | ||||
-rw-r--r-- | compiler/GHC/Parser/PostProcess.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/ThToHs.hs | 42 | ||||
-rw-r--r-- | compiler/GHC/Types/Basic.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Types/SourceText.hs | 28 | ||||
-rw-r--r-- | compiler/GHC/Unit/Module/Warnings.hs | 4 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations-literals/parsed.hs | 25 | ||||
-rw-r--r-- | utils/check-exact/ExactPrint.hs | 26 |
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 -- --------------------------------------------------------------------- |