[Git][ghc/ghc][wip/interpolated-strings-refactor] 4 commits: Reorganize processChars functions

11 Sep 2026

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

    

[Git][ghc/ghc][wip/interpolated-strings-refactor] 4 commits: Reorganize processChars functions

Brandon Chinn (＠brandonchinn178)