Brandon Chinn pushed to branch wip/interpolated-strings-refactor at Glasgow Haskell Compiler / GHC Commits: 6b902264 by Brandon Chinn at 2026-09-10T16:10:56-07:00 Reorganize processChars functions Move functions around, no code changes - - - - - 02af96b6 by Brandon Chinn at 2026-09-10T16:11:13-07:00 Always use processCharsSingle to get StringLexError - - - - - 96e73437 by Brandon Chinn at 2026-09-10T16:11:19-07:00 Add pprHsStringMulti, unify string ppr functions - - - - - deef7392 by Brandon Chinn at 2026-09-10T16:11:22-07:00 Break out Language.Haskell.Syntax.StringMeta - - - - - 8 changed files: - compiler/GHC/Parser.y - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/String.hs - compiler/GHC/Utils/Outputable.hs - + compiler/Language/Haskell/Syntax/StringMeta.hs - compiler/ghc.cabal.in - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout Changes: ===================================== compiler/GHC/Parser.y ===================================== @@ -87,7 +87,6 @@ import GHC.Parser.HaddockLex import GHC.Parser.Annotation import GHC.Parser.Errors.Types import GHC.Parser.Errors.Ppr () -import GHC.Parser.String import GHC.Builtin.WiredIn.Types ( unitTyCon, unitDataCon, sumTyCon, @@ -97,6 +96,7 @@ import GHC.Builtin.WiredIn.Types unrestrictedFunTyCon ) import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import Language.Haskell.Syntax.StringMeta import Language.Haskell.Syntax.Text import qualified Data.Semigroup as Semi ===================================== compiler/GHC/Parser/Lexer.x ===================================== @@ -141,6 +141,7 @@ import qualified GHC.Parser.Lexer.String as Lexer.String import GHC.Parser.String import Language.Haskell.Syntax.Module.Name (ModuleName(..)) +import Language.Haskell.Syntax.StringMeta import Language.Haskell.Syntax.Text } ===================================== compiler/GHC/Parser/String.hs ===================================== @@ -6,10 +6,6 @@ module GHC.Parser.String ( lexString, lexMultilineString, - -- * StringMeta - StringMeta (..), - defaultStrMeta, - -- * Unicode smart quote helpers isDoubleSmartQuote, isSingleSmartQuote, @@ -20,7 +16,6 @@ import GHC.Prelude hiding (getChar) import Control.Arrow ((>>>)) import Control.Monad (when) import Data.Char (chr, ord) -import Data.Data (Data) import qualified Data.Foldable1 as Foldable1 import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (listToMaybe, mapMaybe) @@ -37,19 +32,13 @@ import GHC.Parser.CharClass ( ) import GHC.Parser.Errors.Types (LexErr (..)) import GHC.Utils.Panic (panic) -import Language.Haskell.Syntax.Module.Name (ModuleName) type BufPos = Int data StringLexError = StringLexError LexErr BufPos deriving (Show, Eq) lexString :: Int -> StringBuffer -> Either StringLexError String -lexString = lexStringWith processChars processChars - where - processChars :: HasChar c => [c] -> Either (c, LexErr) [c] - processChars = - collapseGaps - >>> resolveEscapes +lexString = lexStringWith (fromRight . processCharsSingle) -- ----------------------------------------------------------------------------- -- Lexing interface @@ -72,26 +61,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 @@ -128,6 +118,11 @@ bufferLocatedChars initialBuf len = go initialBuf -- ----------------------------------------------------------------------------- -- Lexing phases +processCharsSingle :: HasChar c => [c] -> Either (c, LexErr) [c] +processCharsSingle = + collapseGaps + >>> resolveEscapes + -- | Collapse all string gaps in the given input. -- -- Iterates through the input in `go` until we encounter a backslash. The @@ -185,6 +180,9 @@ resolveEscapes = go nilOL Left (c, e) -> Left (c, e) c : cs -> go (acc `snocOL` c) cs +resolveEscapesMaybe :: HasChar c => [c] -> Maybe [c] +resolveEscapesMaybe = fromRight . resolveEscapes + -- ----------------------------------------------------------------------------- -- Escape characters @@ -284,20 +282,7 @@ isSingleSmartQuote = \case _ -> False -- ----------------------------------------------------------------------------- --- StringMeta - -data StringMeta = StringMeta - { strMetaMultiline :: Bool - , strMetaQualified :: Maybe ModuleName - } - deriving (Show, Data) - -defaultStrMeta :: StringMeta -defaultStrMeta = - StringMeta - { strMetaMultiline = False - , strMetaQualified = Nothing - } +-- QualifiedStrings {- Note [Implementation of QualifiedStrings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -353,88 +338,60 @@ to standard string literals for overlap checking, ensuring that -- and rejoining lines, and instead manually find newline characters, -- for performance. lexMultilineString :: Int -> StringBuffer -> Either StringLexError String -lexMultilineString = lexStringWith processChars processChars +lexMultilineString = lexStringWith processCharsMulti + +processCharsMulti :: String -> Maybe String +processCharsMulti = + collapseGaps -- Step 1 + >>> normalizeEOL + >>> expandLeadingTabs -- Step 3 + >>> rmCommonWhitespacePrefix -- Step 4 + >>> collapseOnlyWsLines -- Step 5 + >>> rmFirstNewline -- Step 7a + >>> rmLastNewline -- Step 7b + >>> resolveEscapesMaybe -- 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 :: String -> String +normalizeEOL = go 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 + 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 + [] -> [] + +-- | Expands all tabs blindly, since the lexer will verify that tabs can only appear +-- as leading indentation +expandLeadingTabs :: String -> String +expandLeadingTabs = go 0 + where + go !col = \case + '\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 + [] -> [] + +rmCommonWhitespacePrefix :: String -> String +rmCommonWhitespacePrefix cs0 = go cs0 + where + commonWSPrefix = getCommonWsPrefix cs0 - 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 + go = \case + c@'\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@('\n' : _) -> cs + _ : cs -> dropLine (x - 1) cs + [] -> [] -- | See step 4 in Note [Multiline string literals] -- @@ -450,6 +407,36 @@ getCommonWsPrefix s = . drop 1 -- ignore first line in calculation $ lines s +collapseOnlyWsLines :: String -> String +collapseOnlyWsLines = go + where + go = \case + c@'\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@('\n' : _) -> Just cs + cs@[] -> Just cs + -- found whitespace, continue + c : cs | is_space c -> checkAllWs cs + -- anything else, stop + _ -> Nothing + +rmFirstNewline :: String -> String +rmFirstNewline = \case + '\n' : cs -> cs + cs -> cs + +rmLastNewline :: String -> String +rmLastNewline = go + where + go = \case + [] -> [] + ['\n'] -> [] + c : cs -> c : go cs + {- Note [Multiline string literals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -488,3 +475,9 @@ It's more precisely defined with the following algorithm: * Lines with only whitespace characters 3. Calculate the longest prefix of whitespace shared by all lines in the remaining list -} + +-- ----------------------------------------------------------------------------- +-- Other utilities + +fromRight :: Either e a -> Maybe a +fromRight = either (const Nothing) Just ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -61,7 +61,10 @@ module GHC.Utils.Outputable ( pprDebugAndThen, pprInfixVar, pprPrefixVar, - pprHsChar, pprHsString, pprHsBytes, + pprHsChar, + pprHsString, pprHsString', + pprHsStringMulti, pprHsStringMulti', + pprHsBytes, primFloatSuffix, primCharSuffix, primDoubleSuffix, primInt8Suffix, primWord8Suffix, @@ -165,7 +168,7 @@ import Data.Void import Control.DeepSeq (NFData(rnf)) import GHC.Fingerprint -import GHC.Show ( showMultiLineString ) +import GHC.Show ( showLitString ) import GHC.Utils.Exception import GHC.Exts (oneShot) @@ -1355,14 +1358,42 @@ 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 :: String -> SDoc -pprHsString fs = vcat (map text (showMultiLineString fs)) +pprHsString fs = char '"' <> pprHsString' fs <> char '"' + +-- | Like 'pprHsString' except without the outer quotes. +pprHsString' :: String -> SDoc +pprHsString' = vcat . map text . showLitStringLines + where + -- Like 'GHC.Show.showMultiLineString', except without wrapping in quotes + showLitStringLines = go id + where + go pre s = + case break (== '\n') s of + (l, '\n':s'@(_:_)) -> (pre $ showLitString l "\\n\\") : go ('\\' :) s' + (l, '\n':[]) -> [pre $ showLitString l "\\n"] + (l, _) -> [pre $ showLitString l ""] + +-- | Special combinator for showing multi-line string literals. +pprHsStringMulti :: FastString -> SDoc +pprHsStringMulti fs = text "\"\"\"" <> pprHsString' (unpackFS fs) <> text "\"\"\"" + +-- | Like 'pprHsStringMulti' except without the outer quotes. +pprHsStringMulti' :: String -> SDoc +pprHsStringMulti' = vcat . map text . showLitStringMultiline + where + showLitChars :: String -> ShowS + showLitChars [] s = s + showLitChars (c : cs) s = showLitChar c (showLitChars cs s) + + showLitStringMultiline :: String -> [String] + showLitStringMultiline = map (flip showLitChars "") . lines -- | 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/StringMeta.hs ===================================== @@ -0,0 +1,27 @@ +module Language.Haskell.Syntax.StringMeta ( + StringMeta (..), + defaultStrMeta, +) where + +import Prelude + +import Language.Haskell.Syntax.Module.Name (ModuleName) + +-- libraries: +import Data.Data (Data) + +-- ----------------------------------------------------------------------------- +-- StringMeta + +data StringMeta = StringMeta + { strMetaMultiline :: Bool + , strMetaQualified :: Maybe ModuleName + } + deriving (Show, Data) + +defaultStrMeta :: StringMeta +defaultStrMeta = + StringMeta + { strMetaMultiline = False + , strMetaQualified = Nothing + } ===================================== compiler/ghc.cabal.in ===================================== @@ -1062,6 +1062,7 @@ Library Language.Haskell.Syntax.Module.Name Language.Haskell.Syntax.Pat Language.Haskell.Syntax.Specificity + Language.Haskell.Syntax.StringMeta Language.Haskell.Syntax.Text Language.Haskell.Syntax.Type ===================================== testsuite/tests/count-deps/CountDepsAst.stdout ===================================== @@ -28,5 +28,6 @@ Language.Haskell.Syntax.Lit Language.Haskell.Syntax.Module.Name Language.Haskell.Syntax.Pat Language.Haskell.Syntax.Specificity +Language.Haskell.Syntax.StringMeta Language.Haskell.Syntax.Text Language.Haskell.Syntax.Type ===================================== testsuite/tests/count-deps/CountDepsParser.stdout ===================================== @@ -303,5 +303,6 @@ Language.Haskell.Syntax.Lit Language.Haskell.Syntax.Module.Name Language.Haskell.Syntax.Pat Language.Haskell.Syntax.Specificity +Language.Haskell.Syntax.StringMeta Language.Haskell.Syntax.Text Language.Haskell.Syntax.Type View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1dc1c81186579d245b2f3e3129154a9... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1dc1c81186579d245b2f3e3129154a9... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help