[Git][ghc/ghc][wip/interpolated-strings] 7 commits: Rewrite showMultiLineString as showLitStringLines
Brandon Chinn (@brandonchinn178)
gitlab at gitlab.haskell.org
Sun Dec 22 04:51:54 UTC 2024
Brandon Chinn pushed to branch wip/interpolated-strings at Glasgow Haskell Compiler / GHC
Commits:
c5da0c13 by Brandon Chinn at 2024-12-21T20:36:24-08:00
Rewrite showMultiLineString as showLitStringLines
- - - - -
b128435c by Brandon Chinn at 2024-12-21T20:49:30-08:00
Fix rendering multiline string without SourceText
- - - - -
6dc4ecc3 by Brandon Chinn at 2024-12-21T20:49:34-08:00
Unify ITstring + ITstringMulti
- - - - -
38847c78 by Brandon Chinn at 2024-12-21T20:49:34-08:00
Unify HsString + HsMultilineString
- - - - -
d9368cdf by Brandon Chinn at 2024-12-21T20:49:34-08:00
Move multiline string processing functions to top-level
- - - - -
9a376559 by Brandon Chinn at 2024-12-21T20:49:34-08:00
Always use processCharsSingle to get StringLexError
- - - - -
619596cd by Brandon Chinn at 2024-12-21T20:51:25-08:00
Implement interpolated strings
- - - - -
29 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Lit.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Match/Literal.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/String.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/Lit.hs
- libraries/base/src/GHC/Show.hs
- libraries/ghc-boot-th/GHC/Internal/TH/Ppr.hs
- libraries/ghc-internal/src/GHC/Internal/Show.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -130,7 +130,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 noExtField (HsString (SourceText $ fsLit "noExpr") (fsLit "noExpr"))
+noExpr = HsLit noExtField (HsString (SourceText $ fsLit "noExpr") HsStringTypeSingle (fsLit "noExpr"))
noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p)
-- Before renaming, and sometimes after
@@ -254,6 +254,10 @@ type instance XIPVar GhcRn = NoExtField
type instance XIPVar GhcTc = DataConCantHappen
type instance XOverLitE (GhcPass _) = NoExtField
type instance XLitE (GhcPass _) = NoExtField
+type instance XInterString (GhcPass _) = NoExtField
+-- | Note: does not contain any delimiters
+type instance XInterStringRaw (GhcPass _) = SourceText
+type instance XInterStringExp (GhcPass _) = NoExtField
type instance XLam (GhcPass _) = EpAnnLam
type instance XApp (GhcPass _) = NoExtField
@@ -710,6 +714,24 @@ ppr_expr (HsOverLabel s l) = case ghcPass @p of
SourceText src -> ftext src
ppr_expr (HsLit _ lit) = ppr lit
ppr_expr (HsOverLit _ lit) = ppr lit
+
+ppr_expr (HsInterString _ strType parts) =
+ char 's' <> delim <> foldMap pprInterPart parts <> delim
+ where
+ pprInterPart = \case
+ HsInterStringRaw st s ->
+ case (strType, st) of
+ (HsStringTypeSingle, SourceText src) -> ftext src
+ (HsStringTypeSingle, NoSourceText) -> pprHsString' (unpackFS s)
+ (HsStringTypeMulti, SourceText src) -> vcat $ map text $ split '\n' (unpackFS src)
+ (HsStringTypeMulti, NoSourceText) -> pprHsStringMulti' (unpackFS s)
+ HsInterStringExpr _ expr -> text "${" <> ppr_expr expr <> text "}"
+
+ delim =
+ case strType of
+ HsStringTypeSingle -> char '"'
+ HsStringTypeMulti -> text "\"\"\""
+
ppr_expr (HsPar _ e) = parens (ppr_lexpr e)
ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e]
=====================================
compiler/GHC/Hs/Lit.hs
=====================================
@@ -48,8 +48,8 @@ import Language.Haskell.Syntax.Lit
type instance XHsChar (GhcPass _) = SourceText
type instance XHsCharPrim (GhcPass _) = SourceText
+-- | Note: contains quote delimiters
type instance XHsString (GhcPass _) = SourceText
-type instance XHsMultilineString (GhcPass _) = SourceText
type instance XHsStringPrim (GhcPass _) = SourceText
type instance XHsInt (GhcPass _) = NoExtField
type instance XHsIntPrim (GhcPass _) = SourceText
@@ -151,7 +151,6 @@ hsLitNeedsParens p = go
go (HsChar {}) = False
go (HsCharPrim {}) = False
go (HsString {}) = False
- go (HsMultilineString {}) = False
go (HsStringPrim {}) = False
go (HsInt _ x) = p > topPrec && il_neg x
go (HsFloatPrim {}) = False
@@ -180,8 +179,7 @@ hsLitNeedsParens p = go
convertLit :: XXLit (GhcPass p)~DataConCantHappen => HsLit (GhcPass p) -> HsLit (GhcPass p')
convertLit (HsChar a x) = HsChar a x
convertLit (HsCharPrim a x) = HsCharPrim a x
-convertLit (HsString a x) = HsString a x
-convertLit (HsMultilineString a x) = HsMultilineString a x
+convertLit (HsString a ty x) = HsString a ty x
convertLit (HsStringPrim a x) = HsStringPrim a x
convertLit (HsInt a x) = HsInt a x
convertLit (HsIntPrim a x) = HsIntPrim a x
@@ -216,11 +214,11 @@ Equivalently it's True if
instance IsPass p => Outputable (HsLit (GhcPass p)) where
ppr (HsChar st c) = pprWithSourceText st (pprHsChar c)
ppr (HsCharPrim st c) = pprWithSourceText st (pprPrimChar c)
- ppr (HsString st s) = pprWithSourceText st (pprHsString s)
- ppr (HsMultilineString st s) =
- case st of
- NoSourceText -> pprHsString s
- SourceText src -> vcat $ map text $ split '\n' (unpackFS src)
+ ppr (HsString st ty s) =
+ case (ty, st) of
+ (HsStringTypeSingle, _) -> pprWithSourceText st (pprHsString s)
+ (HsStringTypeMulti, SourceText src) -> vcat $ map text $ split '\n' (unpackFS src)
+ (HsStringTypeMulti, NoSourceText) -> text "\"\"\"" <> pprHsStringMulti' (unpackFS s) <> text "\"\"\""
ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s)
ppr (HsInt _ i)
= pprWithSourceText (il_text i) (integer (il_value i))
@@ -261,8 +259,7 @@ instance Outputable OverLitVal where
pmPprHsLit :: forall p. IsPass p => HsLit (GhcPass p) -> SDoc
pmPprHsLit (HsChar _ c) = pprHsChar c
pmPprHsLit (HsCharPrim _ c) = pprHsChar c
-pmPprHsLit (HsString st s) = pprWithSourceText st (pprHsString s)
-pmPprHsLit (HsMultilineString st s) = pprWithSourceText st (pprHsString s)
+pmPprHsLit (HsString st _ s) = pprWithSourceText st (pprHsString s)
pmPprHsLit (HsStringPrim _ s) = pprHsBytes s
pmPprHsLit (HsInt _ i) = integer (il_value i)
pmPprHsLit (HsIntPrim _ i) = integer i
=====================================
compiler/GHC/Hs/Syn/Type.hs
=====================================
@@ -74,8 +74,7 @@ hsPatType (SplicePat v _) = dataConCantHappen v
hsLitType :: forall p. IsPass p => HsLit (GhcPass p) -> Type
hsLitType (HsChar _ _) = charTy
hsLitType (HsCharPrim _ _) = charPrimTy
-hsLitType (HsString _ _) = stringTy
-hsLitType (HsMultilineString _ _) = stringTy
+hsLitType (HsString _ _ _) = stringTy
hsLitType (HsStringPrim _ _) = addrPrimTy
hsLitType (HsInt _ _) = intTy
hsLitType (HsIntPrim _ _) = intPrimTy
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -478,10 +478,10 @@ mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
mkHsOpApp e1 op e2 = OpApp noExtField e1 (noLocA (HsVar noExtField (noLocA op))) e2
mkHsString :: String -> HsLit (GhcPass p)
-mkHsString s = HsString NoSourceText (mkFastString s)
+mkHsString s = HsString NoSourceText HsStringTypeSingle (mkFastString s)
mkHsStringFS :: FastString -> HsLit (GhcPass p)
-mkHsStringFS s = HsString NoSourceText s
+mkHsStringFS s = HsString NoSourceText HsStringTypeSingle s
mkHsStringPrimLit :: FastString -> HsLit (GhcPass p)
mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs)
=====================================
compiler/GHC/HsToCore/Match/Literal.hs
=====================================
@@ -120,8 +120,7 @@ dsLit l = do
HsFloatPrim _ fl -> return (Lit (LitFloat (rationalFromFractionalLit fl)))
HsDoublePrim _ fl -> return (Lit (LitDouble (rationalFromFractionalLit fl)))
HsChar _ c -> return (mkCharExpr c)
- HsString _ str -> mkStringExprFS str
- HsMultilineString _ str -> mkStringExprFS str
+ HsString _ _ str -> mkStringExprFS str
HsInt _ i -> return (mkIntExpr platform (il_value i))
XLit x -> case ghcPass @p of
GhcTc -> case x of
@@ -467,7 +466,6 @@ getSimpleIntegralLit (XLit (HsInteger _ i ty)) = Just (i, ty)
getSimpleIntegralLit HsChar{} = Nothing
getSimpleIntegralLit HsCharPrim{} = Nothing
getSimpleIntegralLit HsString{} = Nothing
-getSimpleIntegralLit HsMultilineString{} = Nothing
getSimpleIntegralLit HsStringPrim{} = Nothing
getSimpleIntegralLit (XLit (HsRat{})) = Nothing
getSimpleIntegralLit HsFloatPrim{} = Nothing
@@ -531,7 +529,7 @@ tidyLitPat :: HsLit GhcTc -> Pat GhcTc
-- HsFloatPrim and HsDoublePrim can't show up in LitPats
-- * We get rid of HsChar right here
tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c)
-tidyLitPat (HsString src s)
+tidyLitPat (HsString src _ s)
| lengthFS s <= 1 -- Short string literals only
= unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon
[mkCharLitPat src c, pat] [charTy])
@@ -560,7 +558,7 @@ tidyNPat (OverLit (OverLitTc False _ ty) val) mb_neg _eq outer_ty
| not type_change, isWordTy ty, Just int_lit <- mb_int_lit
= mk_con_pat wordDataCon (HsWordPrim NoSourceText int_lit)
| not type_change, isStringTy ty, Just str_lit <- mb_str_lit
- = tidyLitPat (HsString NoSourceText str_lit)
+ = tidyLitPat (HsString NoSourceText HsStringTypeSingle str_lit)
-- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
-- If we do convert to the constructor form, we'll generate a case
-- expression on a Float# or Double# and that's not allowed in Core; see
@@ -664,7 +662,7 @@ hsLitKey _ (HsCharPrim _ c) = mkLitChar c
hsLitKey _ (HsFloatPrim _ fl) = mkLitFloat (rationalFromFractionalLit fl)
hsLitKey _ (HsDoublePrim _ fl) = mkLitDouble (rationalFromFractionalLit fl)
-hsLitKey _ (HsString _ s) = LitString (bytesFS s)
+hsLitKey _ (HsString _ _ s) = LitString (bytesFS s)
hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
{-
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -3040,8 +3040,7 @@ repLiteral lit
HsDoublePrim _ _ -> Just doublePrimLName
HsChar _ _ -> Just charLName
HsCharPrim _ _ -> Just charPrimLName
- HsString _ _ -> Just stringLName
- HsMultilineString _ _ -> Just stringLName
+ HsString _ _ _ -> Just stringLName
_ -> Nothing
mk_integer :: Integer -> MetaM (HsLit GhcTc)
@@ -3052,7 +3051,7 @@ mk_rational r = do rat_ty <- lookupType rationalTyConName
return $ XLit $ HsRat r rat_ty
mk_string :: FastString -> MetaM (HsLit GhcRn)
-mk_string s = return $ HsString NoSourceText s
+mk_string s = return $ HsString NoSourceText HsStringTypeSingle s
mk_char :: Char -> MetaM (HsLit GhcRn)
mk_char c = return $ HsChar NoSourceText c
=====================================
compiler/GHC/Parser.y
=====================================
@@ -88,6 +88,7 @@ import GHC.Parser.HaddockLex
import GHC.Parser.Annotation
import GHC.Parser.Errors.Types
import GHC.Parser.Errors.Ppr ()
+import GHC.Parser.String (StringType(..))
import GHC.Builtin.Types ( unitTyCon, unitDataCon, sumTyCon,
tupleTyCon, tupleDataCon, nilDataCon,
@@ -727,8 +728,15 @@ are the most common patterns, rewritten as regular expressions for clarity:
LABELVARID { L _ (ITlabelvarid _ _) }
CHAR { L _ (ITchar _ _) }
- STRING { L _ (ITstring _ _) }
- STRING_MULTI { L _ (ITstringMulti _ _) }
+ STRING { L _ (ITstring _ StringTypeSingle _) }
+ STRING_MULTI { L _ (ITstring _ StringTypeMulti _) }
+ STRING_INTER_BEGIN { L _ (ITstringInterBegin StringTypeSingle) }
+ STRING_INTER_END { L _ (ITstringInterEnd StringTypeSingle) }
+ STRING_INTER_MULTI_BEGIN { L _ (ITstringInterBegin StringTypeMulti) }
+ STRING_INTER_MULTI_END { L _ (ITstringInterEnd StringTypeMulti) }
+ STRING_INTER_RAW { L _ (ITstringInterRaw _ _) }
+ STRING_INTER_EXP_OPEN { L _ ITstringInterExpOpen }
+ STRING_INTER_EXP_CLOSE { L _ ITstringInterExpClose }
INTEGER { L _ (ITinteger _) }
RATIONAL { L _ (ITrational _) }
@@ -3113,6 +3121,7 @@ aexp2 :: { ECP }
-- into HsOverLit when -XOverloadedStrings is on.
-- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1)
-- (getSTRING $1) noExtField) }
+ | stringInter { ecpFromExp $1 }
| INTEGER { ECP $ mkHsOverLitPV (sL1a $1 $ mkHsIntegral (getINTEGER $1)) }
| RATIONAL { ECP $ mkHsOverLitPV (sL1a $1 $ mkHsFractional (getRATIONAL $1)) }
@@ -3707,6 +3716,22 @@ ipvar :: { Located HsIPName }
overloaded_label :: { Located (SourceText, FastString) }
: LABELVARID { sL1 $1 (getLABELVARIDs $1, getLABELVARID $1) }
+-----------------------------------------------------------------------------
+-- Interpolated strings
+-- See Note [Interpolated strings] in GHC.Parser.String
+
+stringInter :: { LHsExpr GhcPs }
+ : STRING_INTER_BEGIN stringInterParts STRING_INTER_END { processStringInter StringTypeSingle $1 $2 $3 }
+ | STRING_INTER_MULTI_BEGIN stringInterParts STRING_INTER_MULTI_END { processStringInter StringTypeMulti $1 $2 $3 }
+
+stringInterParts :: { [Either (SourceText, RawLexedString) (LHsExpr GhcPs)] }
+ : stringInterPart { [$1] }
+ | stringInterPart stringInterParts { $1 : $2 }
+
+stringInterPart :: { Either (SourceText, RawLexedString) (LHsExpr GhcPs) }
+ : STRING_INTER_RAW { Left (getStringInterRaw $1) }
+ | STRING_INTER_EXP_OPEN exp STRING_INTER_EXP_CLOSE { Right $2 }
+
-----------------------------------------------------------------------------
-- Warnings and deprecations
@@ -4076,8 +4101,10 @@ consym :: { LocatedN RdrName }
literal :: { Located (HsLit GhcPs) }
: CHAR { sL1 $1 $ HsChar (getCHARs $1) $ getCHAR $1 }
| STRING { sL1 $1 $ HsString (getSTRINGs $1)
+ HsStringTypeSingle
$ getSTRING $1 }
- | STRING_MULTI { sL1 $1 $ HsMultilineString (getSTRINGMULTIs $1)
+ | STRING_MULTI { sL1 $1 $ HsString (getSTRINGMULTIs $1)
+ HsStringTypeMulti
$ getSTRINGMULTI $1 }
| PRIMINTEGER { sL1 $1 $ HsIntPrim (getPRIMINTEGERs $1)
$ getPRIMINTEGER $1 }
@@ -4183,8 +4210,8 @@ getQCONSYM (L _ (ITqconsym x)) = x
getIPDUPVARID (L _ (ITdupipvarid x)) = x
getLABELVARID (L _ (ITlabelvarid _ x)) = x
getCHAR (L _ (ITchar _ x)) = x
-getSTRING (L _ (ITstring _ x)) = x
-getSTRINGMULTI (L _ (ITstringMulti _ x)) = x
+getSTRING (L _ (ITstring _ StringTypeSingle x)) = x
+getSTRINGMULTI (L _ (ITstring _ StringTypeMulti x)) = x
getINTEGER (L _ (ITinteger x)) = x
getRATIONAL (L _ (ITrational x)) = x
getPRIMCHAR (L _ (ITprimchar _ x)) = x
@@ -4209,8 +4236,8 @@ getVOCURLY (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l
getINTEGERs (L _ (ITinteger (IL src _ _))) = src
getCHARs (L _ (ITchar src _)) = src
-getSTRINGs (L _ (ITstring src _)) = src
-getSTRINGMULTIs (L _ (ITstringMulti src _)) = src
+getSTRINGs (L _ (ITstring src StringTypeSingle _)) = src
+getSTRINGMULTIs (L _ (ITstring src StringTypeMulti _)) = src
getPRIMCHARs (L _ (ITprimchar src _)) = src
getPRIMSTRINGs (L _ (ITprimstring src _)) = src
getPRIMINTEGERs (L _ (ITprimint src _)) = src
@@ -4281,6 +4308,70 @@ getSCC lt = do let s = getSTRING lt
stringLiteralToHsDocWst :: Located StringLiteral -> LocatedE (WithHsDocIdentifiers StringLiteral GhcPs)
stringLiteralToHsDocWst sl = reLoc $ lexStringLiteral parseIdentifier sl
+getStringInterRaw :: Located Token -> (SourceText, RawLexedString)
+getStringInterRaw (L _ (ITstringInterRaw src s)) = (src, s)
+
+processStringInter ::
+ StringType
+ -> Located Token
+ -> Located Token
+ -> [Either (SourceText, RawLexedString) (LHsExpr GhcPs)]
+ -> LHsExpr GhcPs
+processStringInter strType tokBegin tokEnd parts =
+ L (comb2 tokBegin tokEnd) $
+ HsInterString noExtField strType $ processParts parts
+ where
+ processParts =
+ map toInterStringPart $
+ case strType of
+ StringTypeSingle -> map (first (fmap fromRawLexedStringSingle))
+ StringTypeMulti -> fromAlt . withoutSrcText fromRawLexedStringMulti . toAlt
+
+ toInterStringPart = \case
+ Left (src, s) -> HsInterStringRaw src (fsLit s)
+ Right e -> HsInterStringExpr noExtField e
+
+ -- Strip SourceText annotations, run the given function, and
+ -- reapply SourceText annotations. Assumes the function does
+ -- not change the order or number of elements, which is true
+ -- for fromRawLexedStringMulti.
+ withoutSrcText ::
+ ((s, [(x, s)]) -> (s, [(x, s)])) ->
+ ((SourceText, s), [(x, (SourceText, s))]) ->
+ ((SourceText, s), [(x, (SourceText, s))])
+ withoutSrcText f vals =
+ let
+ -- extract out (SourceText, [SourceText]) from the parts
+ unannotate ((src, s), parts) = ((src, map (fst . snd) parts), (s, map (fmap snd) parts))
+ -- reapply SourceTexts
+ reannotate ((src0, srcs), (s, parts)) =
+ ( (src0, s)
+ , zipWith (\src (x, s) -> (x, (src, s))) srcs parts
+ )
+ in
+ reannotate . f . unannotate
+
+ toAlt :: Monoid s => [Either s x] -> (s, [(x, s)])
+ toAlt =
+ let go = \case
+ [] -> (mempty, [])
+ Left s : [] -> (s, [])
+ Left s1 : Left s2 : rest -> go $ Left (s1 <> s2) : rest
+ Left s : Right x : rest ->
+ let (s', rest') = go rest
+ in (s, (x, s') : rest')
+ Right x : rest ->
+ let (s, rest') = go rest
+ in (mempty, (x, s) : rest')
+ in go
+
+ fromAlt :: Foldable s => (s, [(x, s)]) -> [Either s x]
+ fromAlt (s, xs) =
+ let notEmpty = \case
+ Left s -> null s
+ Right _ -> True
+ in filter notEmpty $ Left s : concatMap (\(x, s') -> [Right x, Left s']) xs
+
-- Utilities for combining source spans
comb2 :: (HasLoc a, HasLoc b) => a -> b -> SrcSpan
comb2 !a !b = combineHasLocs a b
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -170,7 +170,7 @@ $idchar = [$small $large $digit $uniidchar \']
$unigraphic = \x06 -- Trick Alex into handling Unicode. See Note [Unicode in Alex].
$graphic = [$small $large $symbol $digit $idchar $special $unigraphic \"\']
-$charesc = [a b f n r t v \\ \" \' \&]
+$charesc = [a b f n r t v \\ \" \' \& \$]
$binit = 0-1
$octit = 0-7
@@ -228,8 +228,9 @@ $docsym = [\| \^ \* \$]
-- character sets can be subtracted, not strings
@escape = \\ ( $charesc | @ascii | @decimal | o @octal | x @hexadecimal )
@escapechar = \\ ( $charesc # \& | @ascii | @decimal | o @octal | x @hexadecimal )
- at stringchar = ($graphic # [\\ \"]) | $space | @escape | @gap
- at char = ($graphic # [\\ \']) | $space | @escapechar
+ at stringchar = ($graphic # [\\ \"]) | $space | @escape | @gap
+ at char = ($graphic # [\\ \']) | $space | @escapechar
+ at stringinterchar = ($graphic # [\\ \" \$]) | $space | @escape | @gap
-- normal signed numerical literals can only be explicitly negative,
-- not explicitly positive (contrast @exponent)
@@ -629,6 +630,21 @@ $unigraphic / { isSmartQuote } { smart_quote_error }
(\" | \"\") / ([\n .] # \") { tok_string_multi_content }
}
+-- See Note [Interpolated strings]
+<0> {
+ s \" { \span _ _ _ -> pushLexState string_inter_content >> pure (L span (ITstringInterBegin StringTypeSingle)) }
+ -- TODO(bchinn): interpolated multiline strings
+}
+
+-- TODO(bchinn): add string_inter state to all <0> states that can be in an interpolated string
+<string_inter_content> {
+ @stringinterchar* { tok_string_inter_raw }
+ \$ \{ { \span _ _ _ -> pushLexState string_inter >> pure (L span ITstringInterExpOpen) }
+ \" { \span _ _ _ -> popLexState >> pure (L span (ITstringInterEnd StringTypeSingle)) }
+
+ -- TODO(bchinn): check for smart quotes
+}
+
<0> {
\'\' { token ITtyQuote }
@@ -920,9 +936,16 @@ data Token
-- have a string literal as a label
-- Note [Literal source text] in "GHC.Types.SourceText"
- | ITchar SourceText Char -- Note [Literal source text] in "GHC.Types.SourceText"
- | ITstring SourceText FastString -- Note [Literal source text] in "GHC.Types.SourceText"
- | ITstringMulti SourceText FastString -- Note [Literal source text] in "GHC.Types.SourceText"
+ | ITchar SourceText Char -- Note [Literal source text] in "GHC.Types.SourceText"
+ | ITstring SourceText StringType FastString -- Note [Literal source text] in "GHC.Types.SourceText"
+
+ -- See Note [Interpolated strings]
+ | ITstringInterBegin StringType
+ | ITstringInterRaw SourceText RawLexedString -- Note [Literal source text] in "GHC.Types.SourceText"
+ | ITstringInterExpOpen
+ | ITstringInterExpClose
+ | ITstringInterEnd StringType
+
| ITinteger IntegralLit -- Note [Literal source text] in "GHC.Types.SourceText"
| ITrational FractionalLit
@@ -1672,8 +1695,11 @@ open_brace span _str _len _buf2 = do
setContext (NoLayout:ctx)
return (L span ITocurly)
close_brace span _str _len _buf2 = do
- popContext
- return (L span ITccurly)
+ ctx <- getContext
+ sc <- getLexState
+ if null ctx && sc == string_inter
+ then popLexState >> pure (L span ITstringInterExpClose)
+ else popContext >> pure (L span ITccurly)
qvarid, qconid :: StringBuffer -> Int -> Token
qvarid buf len = ITqvarid $! splitQualName buf len False
@@ -2166,11 +2192,19 @@ tok_string span buf len _buf2 = do
addError err
pure $ L span (ITprimstring src (unsafeMkByteString s))
else
- pure $ L span (ITstring src (mkFastString s))
+ pure $ L span (ITstring src StringTypeSingle (mkFastString s))
where
src = SourceText $ lexemeToFastString buf len
endsInHash = currentChar (offsetBytes (len - 1) buf) == '#'
+tok_string_inter_raw :: Action
+tok_string_inter_raw span buf len _ = do
+ s <- either (throwStringLexError i0) pure $ lexStringRaw len buf
+ pure $ L span (ITstringInterRaw src s)
+ where
+ i0 = AI (psSpanStart span) buf
+ src = SourceText $ lexemeToFastString buf len
+
-- | Ideally, we would define this completely with Alex syntax, like normal strings.
-- Instead, this is defined as a hybrid solution by manually invoking lex states, which
-- we're doing for two reasons:
@@ -2195,10 +2229,10 @@ tok_string_multi startSpan startBuf _len _buf2 = do
let contentLen = byteDiff contentStartBuf contentEndBuf
s <-
either (throwStringLexError (AI startLoc startBuf)) pure $
- lexMultilineString contentLen contentStartBuf
+ lexString StringTypeMulti contentLen contentStartBuf
setInput i'
- pure $ L span $ ITstringMulti src (mkFastString s)
+ pure $ L span $ ITstring src StringTypeMulti (mkFastString s)
where
goContent i0 =
case alexScan i0 string_multi_content of
@@ -2243,7 +2277,7 @@ tok_string_multi_content = panic "tok_string_multi_content unexpectedly invoked"
lex_chars :: (String, String) -> PsSpan -> StringBuffer -> Int -> P String
lex_chars (startDelim, endDelim) span buf len =
either (throwStringLexError i0) pure $
- lexString contentLen contentBuf
+ lexString StringTypeSingle contentLen contentBuf
where
i0@(AI _ contentBuf) = advanceInputBytes (length startDelim) $ AI (psSpanStart span) buf
=====================================
compiler/GHC/Parser/String.hs
=====================================
@@ -5,8 +5,12 @@
module GHC.Parser.String (
StringLexError (..),
+ StringType (..),
lexString,
- lexMultilineString,
+
+ -- * Raw strings
+ RawLexedString,
+ lexStringRaw,
-- * Unicode smart quote helpers
isDoubleSmartQuote,
@@ -17,8 +21,11 @@ import GHC.Prelude hiding (getChar)
import Control.Arrow ((>>>))
import Control.Monad (when)
+import Data.Bifunctor (first)
import Data.Char (chr, ord)
import qualified Data.Foldable1 as Foldable1
+import Data.Functor.Identity (Identity (..))
+import Data.List (unsnoc)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (listToMaybe, mapMaybe)
import GHC.Data.StringBuffer (StringBuffer)
@@ -37,13 +44,16 @@ import GHC.Utils.Panic (panic)
type BufPos = Int
data StringLexError = StringLexError LexErr BufPos
-lexString :: Int -> StringBuffer -> Either StringLexError String
-lexString = lexStringWith processChars processChars
+data StringType = StringTypeSingle | StringTypeMulti deriving (Show)
+
+lexString :: StringType -> Int -> StringBuffer -> Either StringLexError String
+lexString strType = lexStringWith processChars
where
- processChars :: HasChar c => [c] -> Either (c, LexErr) [c]
+ processChars :: HasChar c => [c] -> Maybe [c]
processChars =
- collapseGaps
- >>> resolveEscapes
+ case strType of
+ StringTypeSingle -> fromRight . processCharsSingle
+ StringTypeMulti -> processCharsMulti
-- -----------------------------------------------------------------------------
-- Lexing interface
@@ -66,26 +76,27 @@ So what we'll do is do two passes. The first pass is optimistic; just convert
to a plain String and process it. If this results in an error, we do a second
pass, this time where each character is annotated with its position. Now, the
error has all the information it needs.
-
-Ideally, lexStringWith would take a single (forall c. HasChar c => ...) function,
-but to help the specializer, we pass it in twice to concretize it for the two
-types we actually use.
-}
-- | See Note [Lexing strings]
-lexStringWith ::
- ([Char] -> Either (Char, LexErr) [Char])
- -> ([CharPos] -> Either (CharPos, LexErr) [CharPos])
- -> Int
- -> StringBuffer
- -> Either StringLexError String
-lexStringWith processChars processCharsPos len buf =
+lexStringWith :: (String -> Maybe String) -> Int -> StringBuffer -> Either StringLexError String
+lexStringWith processChars len buf =
case processChars $ bufferChars buf len of
- Right s -> Right s
- Left _ ->
- case processCharsPos $ bufferLocatedChars buf len of
- Right _ -> panic "expected lex error on second pass"
- Left ((_, pos), e) -> Left $ StringLexError e pos
+ Just s -> Right s
+ Nothing -> do
+ validateString len buf -- should return Left
+ panic "expected lex error on second pass"
+
+-- | Find any lexical errors in the string.
+--
+-- Can validate both single- and multi-line strings, since multi-line strings
+-- have the same validation logic as single-line strings, and none of the
+-- multi-line string processing steps affect the validity of the string.
+validateString :: Int -> StringBuffer -> Either StringLexError ()
+validateString len buf =
+ case processCharsSingle $ bufferLocatedChars buf len of
+ Right _ -> Right ()
+ Left ((_, pos), e) -> Left $ StringLexError e pos
class HasChar c where
getChar :: c -> Char
@@ -122,6 +133,11 @@ bufferLocatedChars initialBuf len = go initialBuf
-- -----------------------------------------------------------------------------
-- Lexing phases
+processCharsSingle :: HasChar c => [c] -> Either (c, LexErr) [c]
+processCharsSingle =
+ collapseGaps
+ >>> resolveEscapes
+
collapseGaps :: HasChar c => [c] -> [c]
collapseGaps = go
where
@@ -149,6 +165,9 @@ resolveEscapes = go dlistEmpty
Left (c, e) -> Left (c, e)
c : cs -> go (acc `dlistSnoc` c) cs
+resolveEscapesMaybe :: HasChar c => [c] -> Maybe [c]
+resolveEscapesMaybe = fromRight . resolveEscapes
+
-- -----------------------------------------------------------------------------
-- Escape characters
@@ -247,6 +266,76 @@ isSingleSmartQuote = \case
'’' -> True
_ -> False
+-- -----------------------------------------------------------------------------
+-- Interpolated strings
+
+-- | A string that's been validated to be lexically correct, but still
+-- contains the raw string lexed, without anything resolved.
+newtype RawLexedString = RawLexedString {unRawLexedString :: String}
+ deriving (Foldable, Semigroup, Monoid)
+
+-- | Load and validate the string in the given StringBuffer.
+--
+-- e.g. Lexing "a\nb" will return RawLexedString ['a', '\\', 'n', 'b'].
+lexStringRaw :: Int -> StringBuffer -> Either StringLexError RawLexedString
+lexStringRaw len buf = RawLexedString (bufferChars len buf) <$ validateString len buf
+
+fromRawLexedStringSingle :: RawLexedString -> String
+fromRawLexedStringSingle (RawLexedString s) =
+ case processCharsSingle s of
+ Right s' -> s'
+ Left _ -> panic "Unexpectedly got an error when re-lexing the string"
+
+fromRawLexedStringMulti :: (RawLexedString, [(x, RawLexedString)]) -> (String, [(x, String)])
+fromRawLexedStringMulti s =
+ case processCharsMulti' (to s) of
+ Just s' -> from s'
+ Nothing -> panic "Unexpectedly got an error when re-lexing the string"
+ where
+ to (pre, parts) = InterMultiString pre parts
+ from (InterMultiString pre parts) = (pre, parts)
+
+{-
+Note [Interpolated strings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Interpolated string syntax was accepted in this proposal:
+https://github.com/ghc-proposals/ghc-proposals/pull/570
+
+Interpolated strings are syntax sugar for <TODO(bchinn)>
+
+Interpolated strings are implemented in the following manner:
+
+1. Lexer takes the string as input:
+
+ s"Hello ${Text.toUpper name}!"
+
+ and outputs the following tokens:
+
+ [ ITstringInterBegin src StringTypeSingle
+ , ITstringInterRaw src "Hello "
+ , ITstringInterExpOpen src
+ , ITqvarid ("Text.toUpper", "name")
+ , ITvarid "name"
+ , ITstringInterExpClose src
+ , ITstringInterRaw src "!"
+ , ITstringInterEnd src StringTypeSingle
+ ]
+
+2. The parser will then parse the tokens into the following HsExpr:
+
+ HsInterString ext
+ [ HsInterRaw ext "Hello "
+ , HsInterExp ext $
+ HsApp ext
+ (HsVar ext 'Text.toUpper)
+ (HsVar ext 'name)
+ , HsInterRaw ext "!"
+ ]
+
+3. This will then be desugared into <TODO(bchinn)>
+-}
+
-- -----------------------------------------------------------------------------
-- Multiline strings
@@ -255,89 +344,98 @@ isSingleSmartQuote = \case
-- Assumes string is lexically valid. Skips the steps about splitting
-- and rejoining lines, and instead manually find newline characters,
-- for performance.
-lexMultilineString :: Int -> StringBuffer -> Either StringLexError String
-lexMultilineString = lexStringWith processChars processChars
+processCharsMulti :: String -> Maybe String
+processCharsMulti = fmap from . processCharsMulti' . to
where
- processChars :: HasChar c => [c] -> Either (c, LexErr) [c]
- processChars =
- collapseGaps -- Step 1
- >>> normalizeEOL
- >>> expandLeadingTabs -- Step 3
- >>> rmCommonWhitespacePrefix -- Step 4
- >>> collapseOnlyWsLines -- Step 5
- >>> rmFirstNewline -- Step 7a
- >>> rmLastNewline -- Step 7b
- >>> resolveEscapes -- Step 8
-
- -- Normalize line endings to LF. The spec dictates that lines should be
- -- split on newline characters and rejoined with ``\n``. But because we
- -- aren't actually splitting/rejoining, we'll manually normalize here
- normalizeEOL :: HasChar c => [c] -> [c]
- normalizeEOL =
- let go = \case
- Char '\r' : c@(Char '\n') : cs -> c : go cs
- c@(Char '\r') : cs -> setChar '\n' c : go cs
- c@(Char '\f') : cs -> setChar '\n' c : go cs
- c : cs -> c : go cs
- [] -> []
- in go
-
- -- expands all tabs, since the lexer will verify that tabs can only appear
- -- as leading indentation
- expandLeadingTabs :: HasChar c => [c] -> [c]
- expandLeadingTabs =
- let go !col = \case
- c@(Char '\t') : cs ->
- let fill = 8 - (col `mod` 8)
- in replicate fill (setChar ' ' c) ++ go (col + fill) cs
- c : cs -> c : go (if getChar c == '\n' then 0 else col + 1) cs
- [] -> []
- in go 0
+ -- Convert a normal multiline string to/from an interpolated multiline string
+ -- with no interpolated expressions.
+ to s = InterMultiString s []
+ from = \case
+ InterMultiString s [] -> s
+ _ -> panic "Got unexpected result when processing characters in multiline string"
+
+-- | An interpolated, multiline string to be processed.
+--
+-- `x` here will only ever be instantiated as `HsExpr`, but we'll leave it general to ensure
+-- we never modify it, we only ever propagate it.
+--
+-- We represent this as a list of (x, String) tuples instead of [Either x String] to guarantee
+-- that we don't have to handle two raw Strings next to each other.
+data InterMultiString x =
+ InterMultiString
+ String -- ^ beginning of the string before the first interpolated expr
+ [(x, String)] -- ^ (expr, raw string) interleaved groups
+
+-- Run the given function over all raw strings, ignoring expressions
+overRaw :: (String -> String) -> InterMultiString x -> InterMultiString x
+overRaw f = runIdentity . overRawM (Identity . f)
+
+overRawM :: Monad m => (String -> m String) -> InterMultiString x -> m (InterMultiString x)
+overRawM f (InterMultiString pre parts) = InterMultiString <$> f pre <*> (traverse . traverse) f parts
+
+-- | Process multiline characters generally, for both normal multiline strings and interpolated
+-- multiline strings.
+processCharsMulti' :: InterMultiString x -> Maybe (InterMultiString x)
+processCharsMulti' =
+ overRaw collapseGaps -- Step 1
+ >>> overRaw normalizeEOL
+ >>> expandLeadingTabs -- Step 3
+ >>> rmCommonWhitespacePrefix -- Step 4
+ >>> collapseOnlyWsLines -- Step 5
+ >>> rmFirstNewline -- Step 7a
+ >>> rmLastNewline -- Step 7b
+ >>> overRawM resolveEscapesMaybe -- Step 8
+
+-- | Expands all tabs blindly, since the lexer will verify that tabs can only appear
+-- as leading indentation
+expandLeadingTabs :: InterMultiString x -> InterMultiString x
+expandLeadingTabs =
+ -- we can expand each raw string part independently, because leading
+ -- indentation will never contain an interpolated expression
+ overRaw $ go 0
+ where
+ go !col = \case
+ c@'\t' : cs ->
+ let fill = 8 - (col `mod` 8)
+ in replicate fill ' ' ++ go (col + fill) cs
+ c : cs -> c : go (if c == '\n' then 0 else col + 1) cs
+ [] -> []
+
+-- Normalize line endings to LF. The spec dictates that lines should be
+-- split on newline characters and rejoined with ``\n``. But because we
+-- aren't actually splitting/rejoining, we'll manually normalize here
+normalizeEOL :: String -> String
+normalizeEOL = go
+ where
+ go = \case
+ Char '\r' : c@(Char '\n') : cs -> c : go cs
+ c@(Char '\r') : cs -> setChar '\n' c : go cs
+ c@(Char '\f') : cs -> setChar '\n' c : go cs
+ c : cs -> c : go cs
+ [] -> []
+
+rmCommonWhitespacePrefix :: InterMultiString x -> InterMultiString x
+rmCommonWhitespacePrefix s0 =
+ -- Whitespace prefix, by definition, only comes after newline characters, and there can
+ -- never be an interpolated expr within a whitespace prefix (since the expr would end
+ -- the prefix). So we can use a plain `map` to just process the string parts, because
+ -- the "drop prefix" logic will never span over multiple parts.
+ map (first go) parts
+ where
+ -- treat interpolated exprs as a single, non-space character string
+ commonWSPrefix = getCommonWsPrefix $ case s0 of InterMultiString pre parts -> pre ++ concatMap snd parts
+
+ go = \case
+ c@'\n' : cs -> c : go (dropPrefix commonWSPrefix cs)
+ c : cs -> c : go cs
+ [] -> []
- rmCommonWhitespacePrefix :: HasChar c => [c] -> [c]
- rmCommonWhitespacePrefix cs0 =
- let commonWSPrefix = getCommonWsPrefix (map getChar cs0)
- go = \case
- c@(Char '\n') : cs -> c : go (dropLine commonWSPrefix cs)
- c : cs -> c : go cs
- [] -> []
- -- drop x characters from the string, or up to a newline, whichever
- -- comes first
- dropLine !x = \case
- cs | x <= 0 -> cs
- cs@(Char '\n' : _) -> cs
- _ : cs -> dropLine (x - 1) cs
- [] -> []
- in go cs0
-
- collapseOnlyWsLines :: HasChar c => [c] -> [c]
- collapseOnlyWsLines =
- let go = \case
- c@(Char '\n') : cs | Just cs' <- checkAllWs cs -> c : go cs'
- c : cs -> c : go cs
- [] -> []
- checkAllWs = \case
- -- got all the way to a newline or the end of the string, return
- cs@(Char '\n' : _) -> Just cs
- cs@[] -> Just cs
- -- found whitespace, continue
- Char c : cs | is_space c -> checkAllWs cs
- -- anything else, stop
- _ -> Nothing
- in go
-
- rmFirstNewline :: HasChar c => [c] -> [c]
- rmFirstNewline = \case
- Char '\n' : cs -> cs
- cs -> cs
-
- rmLastNewline :: HasChar c => [c] -> [c]
- rmLastNewline =
- let go = \case
- [] -> []
- [Char '\n'] -> []
- c : cs -> c : go cs
- in go
+ -- drop x characters from the string, or up to a newline, whichever comes first
+ dropPrefix !x = \case
+ cs | x <= 0 -> cs
+ cs@('\n' : _) -> cs
+ _ : cs -> dropPrefix (x - 1) cs
+ [] -> []
-- | See step 4 in Note [Multiline string literals]
--
@@ -353,6 +451,48 @@ getCommonWsPrefix s =
. drop 1 -- ignore first line in calculation
$ lines s
+collapseOnlyWsLines :: InterMultiString x -> InterMultiString x
+collapseOnlyWsLines (InterMultiString pre parts) =
+ let pre' = go (null parts) pre
+ parts' = [(expr, go isLast s) | ((expr, s), isLast) <- withIsLast parts]
+ in InterMultiString pre' parts'
+ where
+ go isLast = \case
+ c@'\n' : cs | Just cs' <- checkAllWs isLast cs -> c : go cs'
+ c : cs -> c : go cs
+ [] -> []
+
+ checkAllWs isLast = \case
+ -- got all the way to a newline or the end of the string, return
+ cs@('\n' : _) -> Just cs
+ cs@[] | isLast -> Just cs
+ -- found whitespace, continue
+ c : cs | is_space c -> checkAllWs cs
+ -- anything else, stop
+ _ -> Nothing
+
+ -- annotate every element with a Bool indicating if it's the last element
+ withIsLast :: [a] -> [(a, Bool)]
+ withIsLast xs = zip xs $ (False <$ init xs) ++ [True]
+
+rmFirstNewline :: InterMultiString x -> InterMultiString x
+rmFirstNewline = \case
+ InterMultiString ('\n' : pre) parts -> InterMultiString pre parts
+ s -> s
+
+rmLastNewline :: InterMultiString x -> InterMultiString x
+rmLastNewline (InterMultiString pre parts) =
+ case unsnoc parts of
+ Nothing ->
+ InterMultiString (go pre) parts
+ Just (parts0, (x, lastLine)) ->
+ InterMultiString pre (parts0 ++ [(x, go lastLine)])
+ where
+ go = \case
+ [] -> []
+ ['\n'] -> []
+ c : cs -> c : go cs
+
{-
Note [Multiline string literals]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -362,8 +502,8 @@ proposal: https://github.com/ghc-proposals/ghc-proposals/pull/569
Multiline string literals are syntax sugar for normal string literals,
with an extra post processing step. This all happens in the Lexer; that
-is, HsMultilineString will contain the post-processed string. This matches
-the same behavior as HsString, which contains the normalized string
+is, HsString will contain the post-processed string. This matches the same
+behavior as single-line HsString, which contains the normalized string
(see Note [Literal source text]).
The canonical steps for post processing a multiline string are:
@@ -405,3 +545,9 @@ dlistToList (DList f) = f []
dlistSnoc :: DList a -> a -> DList a
dlistSnoc (DList f) x = DList (f . (x :))
+
+-- -----------------------------------------------------------------------------
+-- Other utilities
+
+fromRight :: Either e a -> Maybe a
+fromRight = either (const Nothing) Just
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -375,8 +375,7 @@ rnExpr (HsLit x lit) | Just (src, s) <- stringLike lit
; return (HsLit x (convertLit lit), emptyFVs) } }
where
stringLike = \case
- HsString src s -> Just (src, s)
- HsMultilineString src s -> Just (src, s)
+ HsString src _ s -> Just (src, s)
_ -> Nothing
rnExpr (HsLit x lit)
@@ -391,6 +390,9 @@ rnExpr (HsOverLit x lit)
return (HsApp noExtField (noLocA neg) (noLocA (HsOverLit x lit'))
, fvs ) }
+rnExpr (HsInterString x ty parts)
+ = undefined -- TODO(bchinn)
+
rnExpr (HsApp x fun arg)
= do { (fun',fvFun) <- rnLExpr fun
; (arg',fvArg) <- rnLExpr arg
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -565,7 +565,7 @@ rnPatAndThen mk (SigPat _ pat sig)
rnHsPatSigTypeAndThen sig = liftCpsWithCont (rnHsPatSigType AlwaysBind PatCtx sig)
rnPatAndThen mk (LitPat x lit)
- | HsString src s <- lit
+ | HsString src _ s <- lit
= do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)
; if ovlStr
then rnPatAndThen mk
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -427,7 +427,7 @@ mkQuasiQuoteExpr flavour quoter (L q_span' quote)
where
q_span = noAnnSrcSpan (locA q_span')
quoterExpr = L q_span $! HsVar noExtField $! (L (l2l q_span) quoter)
- quoteExpr = L q_span $! HsLit noExtField $! HsString NoSourceText quote
+ quoteExpr = L q_span $! HsLit noExtField $! HsString NoSourceText HsStringTypeSingle quote
quote_selector = case flavour of
UntypedExpSplice -> quoteExpName
UntypedPatSplice -> quotePatName
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -4774,8 +4774,7 @@ addTyConFlavCtxt name flav
tyLitFromLit :: HsLit GhcRn -> Maybe (HsTyLit GhcRn)
-tyLitFromLit (HsString x str) = Just (HsStrTy x str)
-tyLitFromLit (HsMultilineString x str) = Just (HsStrTy x str)
+tyLitFromLit (HsString x _ str) = Just (HsStrTy x str)
tyLitFromLit (HsChar x char) = Just (HsCharTy x char)
tyLitFromLit _ = Nothing
=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -822,7 +822,7 @@ mkOverLit (HsFractional r)
= do { rat_ty <- tcMetaTy rationalTyConName
; return (XLit $ HsRat r rat_ty) }
-mkOverLit (HsIsString src s) = return (HsString src s)
+mkOverLit (HsIsString src s) = return (HsString src HsStringTypeSingle s)
{-
************************************************************************
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -2379,7 +2379,7 @@ shortCutLit platform val res_ty
-- is less than 100, which ensures desugaring isn't slow.
go_string src s
- | isStringTy res_ty = Just (HsLit noExtField (HsString src s))
+ | isStringTy res_ty = Just (HsLit noExtField (HsString src HsStringTypeSingle s))
| otherwise = Nothing
mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1428,7 +1428,7 @@ cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c }
cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c }
cvtLit (StringL s) = do { let { s' = mkFastString s }
; force s'
- ; return $ HsString (quotedSourceText s) s' }
+ ; return $ HsString (quotedSourceText s) HsStringTypeSingle s' }
cvtLit (StringPrimL s) = do { let { !s' = BS.pack s }
; return $ HsStringPrim NoSourceText s' }
cvtLit (BytesPrimL (Bytes fptr off sz)) = do
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -69,7 +69,7 @@ module GHC.Utils.Outputable (
pprDebugAndThen,
pprInfixVar, pprPrefixVar,
- pprHsChar, pprHsString, pprHsBytes,
+ pprHsChar, pprHsString, pprHsString', pprHsStringMulti', pprHsBytes,
primFloatSuffix, primCharSuffix, primDoubleSuffix,
primInt8Suffix, primWord8Suffix,
@@ -161,7 +161,7 @@ import Data.Void
import Control.DeepSeq (NFData(rnf))
import GHC.Fingerprint
-import GHC.Show ( showMultiLineString )
+import GHC.Show ( showLitStringLines, showLitStringMultiline )
import GHC.Utils.Exception
import GHC.Exts (oneShot)
@@ -1297,14 +1297,20 @@ pprHsChar :: Char -> SDoc
pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
| otherwise = text (show c)
--- | Special combinator for showing string literals.
+-- | Special combinator for showing single-line string literals.
pprHsString :: FastString -> SDoc
-pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs)))
+pprHsString fs = char '"' <> pprHsString' (unpackFS fs) <> char '"'
+
+pprHsString' :: String -> SDoc
+pprHsString' = vcat . map text . showLitStringLines
+
+pprHsStringMulti' :: String -> SDoc
+pprHsStringMulti' = vcat . map text . showLitStringMultiline
-- | Special combinator for showing bytestring literals.
pprHsBytes :: ByteString -> SDoc
pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs
- in vcat (map text (showMultiLineString escaped)) <> char '#'
+ in char '"' <> pprHsString' escaped <> text "\"#"
where escape :: Word8 -> String
escape w = let c = chr (fromIntegral w)
in if isAscii c
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -346,19 +346,24 @@ data HsExpr p
-- erroring expression will be written after
-- solving. See Note [Holes] in GHC.Tc.Types.Constraint.
-
-
| HsOverLabel (XOverLabel p) FastString
-- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)
| HsIPVar (XIPVar p)
HsIPName -- ^ Implicit parameter (not in use after typechecking)
+
| HsOverLit (XOverLitE p)
(HsOverLit p) -- ^ Overloaded literals
| HsLit (XLitE p)
(HsLit p) -- ^ Simple (non-overloaded) literals
+ | -- | See Note [Interpolated strings]
+ HsInterString
+ (XInterString p)
+ HsStringType
+ [HsInterStringPart p]
+
-- | Lambda, Lambda-case, and Lambda-cases
| HsLam (XLam p)
HsLamVariant -- ^ Tells whether this is for lambda, \case, or \cases
@@ -589,6 +594,10 @@ data HsLamVariant
| LamCases -- ^ `\cases psi -> ei`
deriving (Data, Eq)
+data HsInterStringPart p
+ = HsInterStringRaw (XInterStringRaw p) FastString
+ | HsInterStringExpr (XInterStringExp p) (LHsExpr p)
+
{-
Note [Parens in HsSyn]
~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -410,6 +410,9 @@ type family XOverLabel x
type family XIPVar x
type family XOverLitE x
type family XLitE x
+type family XInterString x
+type family XInterStringRaw x
+type family XInterStringExp x
type family XLam x
type family XLamCase x
type family XApp x
@@ -550,7 +553,6 @@ type family XXParStmtBlock x x'
type family XHsChar x
type family XHsCharPrim x
type family XHsString x
-type family XHsMultilineString x
type family XHsStringPrim x
type family XHsInt x
type family XHsIntPrim x
=====================================
compiler/Language/Haskell/Syntax/Lit.hs
=====================================
@@ -50,9 +50,7 @@ data HsLit x
-- ^ Character
| HsCharPrim (XHsCharPrim x) {- SourceText -} Char
-- ^ Unboxed character
- | HsString (XHsString x) {- SourceText -} FastString
- -- ^ String
- | HsMultilineString (XHsMultilineString x) {- SourceText -} FastString
+ | HsString (XHsString x) {- SourceText -} HsStringType FastString
-- ^ String
| HsStringPrim (XHsStringPrim x) {- SourceText -} !ByteString
-- ^ Packed bytes
@@ -88,7 +86,7 @@ data HsLit x
instance (Eq (XXLit x)) => Eq (HsLit x) where
(HsChar _ x1) == (HsChar _ x2) = x1==x2
(HsCharPrim _ x1) == (HsCharPrim _ x2) = x1==x2
- (HsString _ x1) == (HsString _ x2) = x1==x2
+ (HsString _ _ x1) == (HsString _ _ x2) = x1==x2
(HsStringPrim _ x1) == (HsStringPrim _ x2) = x1==x2
(HsInt _ x1) == (HsInt _ x2) = x1==x2
(HsIntPrim _ x1) == (HsIntPrim _ x2) = x1==x2
@@ -134,3 +132,6 @@ instance Ord OverLitVal where
compare (HsIsString _ s1) (HsIsString _ s2) = s1 `lexicalCompareFS` s2
compare (HsIsString _ _) (HsIntegral _) = GT
compare (HsIsString _ _) (HsFractional _) = GT
+
+data HsStringType = HsStringTypeSingle | HsStringTypeMulti
+ deriving Data
=====================================
libraries/base/src/GHC/Show.hs
=====================================
@@ -18,7 +18,7 @@ module GHC.Show
Show(..), ShowS,
-- * Show support code
- shows, showChar, showString, showMultiLineString,
+ shows, showChar, showString, showLitStringLines, showLitStringMultiline,
showParen, showList__, showCommaSpace, showSpace,
showLitChar, showLitString, protectEsc,
intToDigit, showSignedInt,
=====================================
libraries/ghc-boot-th/GHC/Internal/TH/Ppr.hs
=====================================
@@ -14,7 +14,7 @@ import GHC.Internal.TH.Syntax
import Data.Word ( Word8 )
import Data.Char ( toLower, chr )
import Data.List ( intersperse )
-import GHC.Show ( showMultiLineString )
+import GHC.Show ( showLitStringLines )
import GHC.Lexeme( isVarSymChar )
import Data.Ratio ( numerator, denominator )
import Data.Foldable ( toList )
@@ -359,7 +359,7 @@ bytesToString = map (chr . fromIntegral)
pprString :: String -> Doc
-- Print newlines as newlines with Haskell string escape notation,
-- not as '\n'. For other non-printables use regular escape notation.
-pprString s = vcat (map text (showMultiLineString s))
+pprString s = char '"' <> vcat (map text (showLitStringLines s)) <> char '"'
------------------------------
instance Ppr Pat where
=====================================
libraries/ghc-internal/src/GHC/Internal/Show.hs
=====================================
@@ -38,7 +38,7 @@ module GHC.Internal.Show
-- Instances for Show: (), [], Bool, Ordering, Int, Char
-- Show support code
- shows, showChar, showString, showMultiLineString,
+ shows, showChar, showString, showLitStringLines, showLitStringMultiline,
showParen, showList__, showCommaSpace, showSpace,
showLitChar, showLitString, protectEsc,
intToDigit, showSignedInt,
@@ -389,13 +389,17 @@ showLitChar c s = showString ('\\' : asciiTab!!ord c) s
-- I've done manual eta-expansion here, because otherwise it's
-- impossible to stop (asciiTab!!ord) getting floated out as an MFE
+showLitChars :: String -> ShowS
+showLitChars [] s = s
+showLitChars (c : cs) s = showLitChar c (showLitChars cs s)
+
showLitString :: String -> ShowS
-- | Same as 'showLitChar', but for strings
-- It converts the string to a string using Haskell escape conventions
-- for non-printable characters. Does not add double-quotes around the
-- whole thing; the caller should do that.
--- The main difference from showLitChar (apart from the fact that the
--- argument is a string not a list) is that we must escape double-quotes
+-- The main difference from showLitChar (apart from iterating over all Chars
+-- in the String) is that we must escape double-quotes
showLitString [] s = s
showLitString ('"' : cs) s = showString "\\\"" (showLitString cs s)
showLitString (c : cs) s = showLitChar c (showLitString cs s)
@@ -404,20 +408,32 @@ showLitString (c : cs) s = showLitChar c (showLitString cs s)
-- The sticking point is the recursive call to (showLitString cs), which
-- it can't figure out would be ok with arity 2.
-showMultiLineString :: String -> [String]
--- | Like 'showLitString' (expand escape characters using Haskell
--- escape conventions), but
--- * break the string into multiple lines
--- * wrap the entire thing in double quotes
--- Example: @showMultiLineString "hello\ngoodbye\nblah"@
--- returns @["\"hello\\n\\", "\\goodbye\n\\", "\\blah\""]@
-showMultiLineString str
- = go '\"' str
+-- | Like 'showLitString', but split on newlines, assuming that all newlines
+-- were written with string gaps.
+--
+-- Example: @showLitStringLines "hello\ngoodbye\nblah"@
+-- returns @["hello\\n\\", "\\goodbye\n\\", "\\blah"]@
+--
+-- Caller is responsible for adding double-quotes around the result.
+showLitStringLines :: String -> [String]
+showLitStringLines str
+ = go id str
+ where
+ go pre s = case break (== '\n') s of
+ (l, _:s'@(_:_)) -> (pre $ showLitString l "\\n\\") : go ('\\' :) s'
+ (l, "\n") -> [pre $ showLitString l "\\n"]
+ (l, _) -> [pre $ showLitString l ""]
+
+-- | Split input into lines and escape characters in a multiline string.
+-- Does not include start/end delimiters.
+showLitStringMultiline :: String -> [String]
+showLitStringMultiline = map (flip showLitChars "") . lines
where
- go ch s = case break (== '\n') s of
- (l, _:s'@(_:_)) -> (ch : showLitString l "\\n\\") : go '\\' s'
- (l, "\n") -> [ch : showLitString l "\\n\""]
- (l, _) -> [ch : showLitString l "\""]
+ lines "" = []
+ lines s =
+ case break (== '\n') s of
+ (line, _ : s') -> line : lines s'
+ (line, []) -> [line]
isDec :: Char -> Bool
isDec c = c >= '0' && c <= '9'
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -9322,7 +9322,7 @@ module GHC.Show where
showList__ :: forall a. (a -> ShowS) -> [a] -> ShowS
showLitChar :: GHC.Types.Char -> ShowS
showLitString :: GHC.Internal.Base.String -> ShowS
- showMultiLineString :: GHC.Internal.Base.String -> [GHC.Internal.Base.String]
+ showLitStringLines :: GHC.Internal.Base.String -> [GHC.Internal.Base.String]
showParen :: GHC.Types.Bool -> ShowS -> ShowS
showSignedInt :: GHC.Types.Int -> GHC.Types.Int -> ShowS
showSpace :: ShowS
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -12364,7 +12364,7 @@ module GHC.Show where
showList__ :: forall a. (a -> ShowS) -> [a] -> ShowS
showLitChar :: GHC.Types.Char -> ShowS
showLitString :: GHC.Internal.Base.String -> ShowS
- showMultiLineString :: GHC.Internal.Base.String -> [GHC.Internal.Base.String]
+ showLitStringLines :: GHC.Internal.Base.String -> [GHC.Internal.Base.String]
showParen :: GHC.Types.Bool -> ShowS -> ShowS
showSignedInt :: GHC.Types.Int -> GHC.Types.Int -> ShowS
showSpace :: ShowS
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -9546,7 +9546,7 @@ module GHC.Show where
showList__ :: forall a. (a -> ShowS) -> [a] -> ShowS
showLitChar :: GHC.Types.Char -> ShowS
showLitString :: GHC.Internal.Base.String -> ShowS
- showMultiLineString :: GHC.Internal.Base.String -> [GHC.Internal.Base.String]
+ showLitStringLines :: GHC.Internal.Base.String -> [GHC.Internal.Base.String]
showParen :: GHC.Types.Bool -> ShowS -> ShowS
showSignedInt :: GHC.Types.Int -> GHC.Types.Int -> ShowS
showSpace :: ShowS
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -9322,7 +9322,7 @@ module GHC.Show where
showList__ :: forall a. (a -> ShowS) -> [a] -> ShowS
showLitChar :: GHC.Types.Char -> ShowS
showLitString :: GHC.Internal.Base.String -> ShowS
- showMultiLineString :: GHC.Internal.Base.String -> [GHC.Internal.Base.String]
+ showLitStringLines :: GHC.Internal.Base.String -> [GHC.Internal.Base.String]
showParen :: GHC.Types.Bool -> ShowS -> ShowS
showSignedInt :: GHC.Types.Int -> GHC.Types.Int -> ShowS
showSpace :: ShowS
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -4768,8 +4768,7 @@ hsLit2String lit =
case lit of
HsChar src v -> toSourceTextWithSuffix src v ""
HsCharPrim src p -> toSourceTextWithSuffix src p ""
- HsString src v -> toSourceTextWithSuffix src v ""
- HsMultilineString src v -> toSourceTextWithSuffix src v ""
+ HsString src _ v -> toSourceTextWithSuffix src v ""
HsStringPrim src v -> toSourceTextWithSuffix src v ""
HsInt _ (IL src _ v) -> toSourceTextWithSuffix src v ""
HsIntPrim src v -> toSourceTextWithSuffix src v ""
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
=====================================
@@ -23,6 +23,7 @@ import GHC.Parser.Lexer as Lexer
, initParserState
, lexer
)
+import GHC.Parser.String (StringType (..))
import qualified GHC.Types.Error as E
import GHC.Types.SourceText
import GHC.Types.SrcLoc
@@ -118,7 +119,7 @@ parse parserOpts sDocContext fpath bs = case unP (go False []) initState of
-- Update internal line + file position if this is a LINE pragma
ITline_prag _ -> tryOrElse (bEnd, inPragDef) $ do
L _ (ITinteger (IL{il_value = line})) <- tryP wrappedLexer
- L _ (ITstring _ file) <- tryP wrappedLexer
+ L _ (ITstring _ StringTypeSingle file) <- tryP wrappedLexer
L spF ITclose_prag <- tryP wrappedLexer
let newLoc = mkRealSrcLoc file (fromIntegral line - 1) (srcSpanEndCol spF)
@@ -320,7 +321,6 @@ classify tok =
ITlabelvarid{} -> TkUnknown
ITchar{} -> TkChar
ITstring{} -> TkString
- ITstringMulti{} -> TkString
ITinteger{} -> TkNumber
ITrational{} -> TkNumber
ITprimchar{} -> TkChar
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/40a9d4458428aeab496a9ab1864da368a7ef15f4...619596cd178c6fc6e6d8c0b93f4855ff047e623b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/40a9d4458428aeab496a9ab1864da368a7ef15f4...619596cd178c6fc6e6d8c0b93f4855ff047e623b
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241221/2899f205/attachment-0001.html>
More information about the ghc-commits
mailing list