Brandon Chinn pushed to branch wip/interpolated-strings-refactor at Glasgow Haskell Compiler / GHC

Commits:

8 changed files:

Changes:

  • compiler/GHC/Parser.y
    ... ... @@ -87,7 +87,6 @@ import GHC.Parser.HaddockLex
    87 87 
     import GHC.Parser.Annotation
    88 88 
     import GHC.Parser.Errors.Types
    89 89 
     import GHC.Parser.Errors.Ppr ()
    90 
    -import GHC.Parser.String
    91 90
    92 91 
     import GHC.Builtin.WiredIn.Types
    93 92 
                 ( unitTyCon, unitDataCon, sumTyCon,
    ... ... @@ -97,6 +96,7 @@ import GHC.Builtin.WiredIn.Types
    97 96 
                   unrestrictedFunTyCon )
    98 97
    99 98 
     import Language.Haskell.Syntax.Basic (FieldLabelString(..))
    99 
    +import Language.Haskell.Syntax.StringMeta
    100 100 
     import Language.Haskell.Syntax.Text
    101 101
    102 102 
     import qualified Data.Semigroup as Semi

  • compiler/GHC/Parser/Lexer.x
    ... ... @@ -141,6 +141,7 @@ import qualified GHC.Parser.Lexer.String as Lexer.String
    141 141 
     import GHC.Parser.String
    142 142
    143 143 
     import Language.Haskell.Syntax.Module.Name (ModuleName(..))
    144 
    +import Language.Haskell.Syntax.StringMeta
    144 145 
     import Language.Haskell.Syntax.Text
    145 146 
     }
    146 147

  • compiler/GHC/Parser/String.hs
    ... ... @@ -6,10 +6,6 @@ module GHC.Parser.String (
    6 6 
       lexString,
    7 7 
       lexMultilineString,
    8 8
    9 
    -  -- * StringMeta
    10 
    -  StringMeta (..),
    11 
    -  defaultStrMeta,
    12 
    -
    13 9 
       -- * Unicode smart quote helpers
    14 10 
       isDoubleSmartQuote,
    15 11 
       isSingleSmartQuote,
    ... ... @@ -20,7 +16,6 @@ import GHC.Prelude hiding (getChar)
    20 16 
     import Control.Arrow ((>>>))
    21 17 
     import Control.Monad (when)
    22 18 
     import Data.Char (chr, ord)
    23 
    -import Data.Data (Data)
    24 19 
     import qualified Data.Foldable1 as Foldable1
    25 20 
     import qualified Data.List.NonEmpty as NonEmpty
    26 21 
     import Data.Maybe (listToMaybe, mapMaybe)
    ... ... @@ -37,19 +32,13 @@ import GHC.Parser.CharClass (
    37 32 
      )
    38 33 
     import GHC.Parser.Errors.Types (LexErr (..))
    39 34 
     import GHC.Utils.Panic (panic)
    40 
    -import Language.Haskell.Syntax.Module.Name (ModuleName)
    41 35
    42 36 
     type BufPos = Int
    43 37 
     data StringLexError = StringLexError LexErr BufPos
    44 38 
       deriving (Show, Eq)
    45 39
    46 40 
     lexString :: Int -> StringBuffer -> Either StringLexError String
    47 
    -lexString = lexStringWith processChars processChars
    48 
    -  where
    49 
    -    processChars :: HasChar c => [c] -> Either (c, LexErr) [c]
    50 
    -    processChars =
    51 
    -          collapseGaps
    52 
    -      >>> resolveEscapes
    41 
    +lexString = lexStringWith (fromRight . processCharsSingle)
    53 42
    54 43 
     -- -----------------------------------------------------------------------------
    55 44 
     -- Lexing interface
    ... ... @@ -72,26 +61,27 @@ So what we'll do is do two passes. The first pass is optimistic; just convert
    72 61 
     to a plain String and process it. If this results in an error, we do a second
    73 62 
     pass, this time where each character is annotated with its position. Now, the
    74 63 
     error has all the information it needs.
    75 
    -
    76 
    -Ideally, lexStringWith would take a single (forall c. HasChar c => ...) function,
    77 
    -but to help the specializer, we pass it in twice to concretize it for the two
    78 
    -types we actually use.
    79 64 
     -}
    80 65
    81 66 
     -- | See Note [Lexing strings]
    82 
    -lexStringWith ::
    83 
    -  ([Char] -> Either (Char, LexErr) [Char])
    84 
    -  -> ([CharPos] -> Either (CharPos, LexErr) [CharPos])
    85 
    -  -> Int
    86 
    -  -> StringBuffer
    87 
    -  -> Either StringLexError String
    88 
    -lexStringWith processChars processCharsPos len buf =
    67 
    +lexStringWith :: (String -> Maybe String) -> Int -> StringBuffer -> Either StringLexError String
    68 
    +lexStringWith processChars len buf =
    89 69 
       case processChars $ bufferChars buf len of
    90 
    -    Right s -> Right s
    91 
    -    Left _ ->
    92 
    -      case processCharsPos $ bufferLocatedChars buf len of
    93 
    -        Right _ -> panic "expected lex error on second pass"
    94 
    -        Left ((_, pos), e) -> Left $ StringLexError e pos
    70 
    +    Just s -> Right s
    71 
    +    Nothing -> do
    72 
    +      validateString len buf -- should return Left
    73 
    +      panic "expected lex error on second pass"
    74 
    +
    75 
    +-- | Find any lexical errors in the string.
    76 
    +--
    77 
    +-- Can validate both single- and multi-line strings, since multi-line strings
    78 
    +-- have the same validation logic as single-line strings, and none of the
    79 
    +-- multi-line string processing steps affect the validity of the string.
    80 
    +validateString :: Int -> StringBuffer -> Either StringLexError ()
    81 
    +validateString len buf =
    82 
    +  case processCharsSingle $ bufferLocatedChars buf len of
    83 
    +    Right _ -> Right ()
    84 
    +    Left ((_, pos), e) -> Left $ StringLexError e pos
    95 85
    96 86 
     class HasChar c where
    97 87 
       getChar :: c -> Char
    ... ... @@ -128,6 +118,11 @@ bufferLocatedChars initialBuf len = go initialBuf
    128 118 
     -- -----------------------------------------------------------------------------
    129 119 
     -- Lexing phases
    130 120
    121 
    +processCharsSingle :: HasChar c => [c] -> Either (c, LexErr) [c]
    122 
    +processCharsSingle =
    123 
    +      collapseGaps
    124 
    +  >>> resolveEscapes
    125 
    +
    131 126 
     -- | Collapse all string gaps in the given input.
    132 127 
     --
    133 128 
     -- Iterates through the input in `go` until we encounter a backslash. The
    ... ... @@ -185,6 +180,9 @@ resolveEscapes = go nilOL
    185 180 
               Left (c, e) -> Left (c, e)
    186 181 
           c : cs -> go (acc `snocOL` c) cs
    187 182
    183 
    +resolveEscapesMaybe :: HasChar c => [c] -> Maybe [c]
    184 
    +resolveEscapesMaybe = fromRight . resolveEscapes
    185 
    +
    188 186 
     -- -----------------------------------------------------------------------------
    189 187 
     -- Escape characters
    190 188
    ... ... @@ -284,20 +282,7 @@ isSingleSmartQuote = \case
    284 282 
       _ -> False
    285 283
    286 284 
     -- -----------------------------------------------------------------------------
    287 
    --- StringMeta
    288 
    -
    289 
    -data StringMeta = StringMeta
    290 
    -  { strMetaMultiline  :: Bool
    291 
    -  , strMetaQualified  :: Maybe ModuleName
    292 
    -  }
    293 
    -  deriving (Show, Data)
    294 
    -
    295 
    -defaultStrMeta :: StringMeta
    296 
    -defaultStrMeta =
    297 
    -  StringMeta
    298 
    -    { strMetaMultiline = False
    299 
    -    , strMetaQualified = Nothing
    300 
    -    }
    285 
    +-- QualifiedStrings
    301 286
    302 287 
     {- Note [Implementation of QualifiedStrings]
    303 288 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -353,88 +338,60 @@ to standard string literals for overlap checking, ensuring that
    353 338 
     -- and rejoining lines, and instead manually find newline characters,
    354 339 
     -- for performance.
    355 340 
     lexMultilineString :: Int -> StringBuffer -> Either StringLexError String
    356 
    -lexMultilineString = lexStringWith processChars processChars
    341 
    +lexMultilineString = lexStringWith processCharsMulti
    342 
    +
    343 
    +processCharsMulti :: String -> Maybe String
    344 
    +processCharsMulti =
    345 
    +      collapseGaps             -- Step 1
    346 
    +  >>> normalizeEOL
    347 
    +  >>> expandLeadingTabs        -- Step 3
    348 
    +  >>> rmCommonWhitespacePrefix -- Step 4
    349 
    +  >>> collapseOnlyWsLines      -- Step 5
    350 
    +  >>> rmFirstNewline           -- Step 7a
    351 
    +  >>> rmLastNewline            -- Step 7b
    352 
    +  >>> resolveEscapesMaybe      -- Step 8
    353 
    +
    354 
    +-- Normalize line endings to LF. The spec dictates that lines should be
    355 
    +-- split on newline characters and rejoined with ``\n``. But because we
    356 
    +-- aren't actually splitting/rejoining, we'll manually normalize here
    357 
    +normalizeEOL :: String -> String
    358 
    +normalizeEOL = go
    357 359 
       where
    358 
    -    processChars :: HasChar c => [c] -> Either (c, LexErr) [c]
    359 
    -    processChars =
    360 
    -          collapseGaps             -- Step 1
    361 
    -      >>> normalizeEOL
    362 
    -      >>> expandLeadingTabs        -- Step 3
    363 
    -      >>> rmCommonWhitespacePrefix -- Step 4
    364 
    -      >>> collapseOnlyWsLines      -- Step 5
    365 
    -      >>> rmFirstNewline           -- Step 7a
    366 
    -      >>> rmLastNewline            -- Step 7b
    367 
    -      >>> resolveEscapes           -- Step 8
    368 
    -
    369 
    -    -- Normalize line endings to LF. The spec dictates that lines should be
    370 
    -    -- split on newline characters and rejoined with ``\n``. But because we
    371 
    -    -- aren't actually splitting/rejoining, we'll manually normalize here
    372 
    -    normalizeEOL :: HasChar c => [c] -> [c]
    373 
    -    normalizeEOL =
    374 
    -      let go = \case
    375 
    -            Char '\r' : c@(Char '\n') : cs -> c : go cs
    376 
    -            c@(Char '\r') : cs -> setChar '\n' c : go cs
    377 
    -            c@(Char '\f') : cs -> setChar '\n' c : go cs
    378 
    -            c : cs -> c : go cs
    379 
    -            [] -> []
    380 
    -       in go
    381 
    -
    382 
    -    -- expands all tabs, since the lexer will verify that tabs can only appear
    383 
    -    -- as leading indentation
    384 
    -    expandLeadingTabs :: HasChar c => [c] -> [c]
    385 
    -    expandLeadingTabs =
    386 
    -      let go !col = \case
    387 
    -            c@(Char '\t') : cs ->
    388 
    -              let fill = 8 - (col `mod` 8)
    389 
    -               in replicate fill (setChar ' ' c) ++ go (col + fill) cs
    390 
    -            c : cs -> c : go (if getChar c == '\n' then 0 else col + 1) cs
    391 
    -            [] -> []
    392 
    -       in go 0
    360 
    +    go = \case
    361 
    +      Char '\r' : c@(Char '\n') : cs -> c : go cs
    362 
    +      c@(Char '\r') : cs -> setChar '\n' c : go cs
    363 
    +      c@(Char '\f') : cs -> setChar '\n' c : go cs
    364 
    +      c : cs -> c : go cs
    365 
    +      [] -> []
    366 
    +
    367 
    +-- | Expands all tabs blindly, since the lexer will verify that tabs can only appear
    368 
    +-- as leading indentation
    369 
    +expandLeadingTabs :: String -> String
    370 
    +expandLeadingTabs = go 0
    371 
    +  where
    372 
    +    go !col = \case
    373 
    +      '\t' : cs ->
    374 
    +        let fill = 8 - (col `mod` 8)
    375 
    +         in replicate fill ' ' ++ go (col + fill) cs
    376 
    +      c : cs -> c : go (if c == '\n' then 0 else col + 1) cs
    377 
    +      [] -> []
    378 
    +
    379 
    +rmCommonWhitespacePrefix :: String -> String
    380 
    +rmCommonWhitespacePrefix cs0 = go cs0
    381 
    +  where
    382 
    +    commonWSPrefix = getCommonWsPrefix cs0
    393 383
    394 
    -    rmCommonWhitespacePrefix :: HasChar c => [c] -> [c]
    395 
    -    rmCommonWhitespacePrefix cs0 =
    396 
    -      let commonWSPrefix = getCommonWsPrefix (map getChar cs0)
    397 
    -          go = \case
    398 
    -            c@(Char '\n') : cs -> c : go (dropLine commonWSPrefix cs)
    399 
    -            c : cs -> c : go cs
    400 
    -            [] -> []
    401 
    -          -- drop x characters from the string, or up to a newline, whichever
    402 
    -          -- comes first
    403 
    -          dropLine !x = \case
    404 
    -            cs | x <= 0 -> cs
    405 
    -            cs@(Char '\n' : _) -> cs
    406 
    -            _ : cs -> dropLine (x - 1) cs
    407 
    -            [] -> []
    408 
    -       in go cs0
    409 
    -
    410 
    -    collapseOnlyWsLines :: HasChar c => [c] -> [c]
    411 
    -    collapseOnlyWsLines =
    412 
    -      let go = \case
    413 
    -            c@(Char '\n') : cs | Just cs' <- checkAllWs cs -> c : go cs'
    414 
    -            c : cs -> c : go cs
    415 
    -            [] -> []
    416 
    -          checkAllWs = \case
    417 
    -            -- got all the way to a newline or the end of the string, return
    418 
    -            cs@(Char '\n' : _) -> Just cs
    419 
    -            cs@[] -> Just cs
    420 
    -            -- found whitespace, continue
    421 
    -            Char c : cs | is_space c -> checkAllWs cs
    422 
    -            -- anything else, stop
    423 
    -            _ -> Nothing
    424 
    -       in go
    425 
    -
    426 
    -    rmFirstNewline :: HasChar c => [c] -> [c]
    427 
    -    rmFirstNewline = \case
    428 
    -      Char '\n' : cs -> cs
    429 
    -      cs -> cs
    430 
    -
    431 
    -    rmLastNewline :: HasChar c => [c] -> [c]
    432 
    -    rmLastNewline =
    433 
    -      let go = \case
    434 
    -            [] -> []
    435 
    -            [Char '\n'] -> []
    436 
    -            c : cs -> c : go cs
    437 
    -       in go
    384 
    +    go = \case
    385 
    +      c@'\n' : cs -> c : go (dropLine commonWSPrefix cs)
    386 
    +      c : cs -> c : go cs
    387 
    +      [] -> []
    388 
    +
    389 
    +    -- drop x characters from the string, or up to a newline, whichever comes first
    390 
    +    dropLine !x = \case
    391 
    +      cs | x <= 0 -> cs
    392 
    +      cs@('\n' : _) -> cs
    393 
    +      _ : cs -> dropLine (x - 1) cs
    394 
    +      [] -> []
    438 395
    439 396 
     -- | See step 4 in Note [Multiline string literals]
    440 397 
     --
    ... ... @@ -450,6 +407,36 @@ getCommonWsPrefix s =
    450 407 
           . drop 1                      -- ignore first line in calculation
    451 408 
           $ lines s
    452 409
    410 
    +collapseOnlyWsLines :: String -> String
    411 
    +collapseOnlyWsLines = go
    412 
    +  where
    413 
    +    go = \case
    414 
    +      c@'\n' : cs | Just cs' <- checkAllWs cs -> c : go cs'
    415 
    +      c : cs -> c : go cs
    416 
    +      [] -> []
    417 
    +
    418 
    +    checkAllWs = \case
    419 
    +      -- got all the way to a newline or the end of the string, return
    420 
    +      cs@('\n' : _) -> Just cs
    421 
    +      cs@[] -> Just cs
    422 
    +      -- found whitespace, continue
    423 
    +      c : cs | is_space c -> checkAllWs cs
    424 
    +      -- anything else, stop
    425 
    +      _ -> Nothing
    426 
    +
    427 
    +rmFirstNewline :: String -> String
    428 
    +rmFirstNewline = \case
    429 
    +  '\n' : cs -> cs
    430 
    +  cs -> cs
    431 
    +
    432 
    +rmLastNewline :: String -> String
    433 
    +rmLastNewline = go
    434 
    +  where
    435 
    +    go = \case
    436 
    +      [] -> []
    437 
    +      ['\n'] -> []
    438 
    +      c : cs -> c : go cs
    439 
    +
    453 440 
     {-
    454 441 
     Note [Multiline string literals]
    455 442 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -488,3 +475,9 @@ It's more precisely defined with the following algorithm:
    488 475 
         * Lines with only whitespace characters
    489 476 
     3. Calculate the longest prefix of whitespace shared by all lines in the remaining list
    490 477 
     -}
    478 
    +
    479 
    +-- -----------------------------------------------------------------------------
    480 
    +-- Other utilities
    481 
    +
    482 
    +fromRight :: Either e a -> Maybe a
    483 
    +fromRight = either (const Nothing) Just

  • compiler/GHC/Utils/Outputable.hs
    ... ... @@ -61,7 +61,10 @@ module GHC.Utils.Outputable (
    61 61 
             pprDebugAndThen,
    62 62
    63 63 
             pprInfixVar, pprPrefixVar,
    64 
    -        pprHsChar, pprHsString, pprHsBytes,
    64 
    +        pprHsChar,
    65 
    +        pprHsString, pprHsString',
    66 
    +        pprHsStringMulti, pprHsStringMulti',
    67 
    +        pprHsBytes,
    65 68
    66 69 
             primFloatSuffix, primCharSuffix, primDoubleSuffix,
    67 70 
             primInt8Suffix, primWord8Suffix,
    ... ... @@ -165,7 +168,7 @@ import Data.Void
    165 168 
     import Control.DeepSeq (NFData(rnf))
    166 169
    167 170 
     import GHC.Fingerprint
    168 
    -import GHC.Show         ( showMultiLineString )
    171 
    +import GHC.Show         ( showLitString )
    169 172 
     import GHC.Utils.Exception
    170 173 
     import GHC.Exts (oneShot)
    171 174
    ... ... @@ -1355,14 +1358,42 @@ pprHsChar :: Char -> SDoc
    1355 1358 
     pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
    1356 1359 
                 | otherwise      = text (show c)
    1357 1360
    1358 
    --- | Special combinator for showing string literals.
    1361 
    +-- | Special combinator for showing single-line string literals.
    1359 1362 
     pprHsString :: String -> SDoc
    1360 
    -pprHsString fs = vcat (map text (showMultiLineString fs))
    1363 
    +pprHsString fs = char '"' <> pprHsString' fs <> char '"'
    1364 
    +
    1365 
    +-- | Like 'pprHsString' except without the outer quotes.
    1366 
    +pprHsString' :: String -> SDoc
    1367 
    +pprHsString' = vcat . map text . showLitStringLines
    1368 
    +  where
    1369 
    +    -- Like 'GHC.Show.showMultiLineString', except without wrapping in quotes
    1370 
    +    showLitStringLines = go id
    1371 
    +      where
    1372 
    +        go pre s =
    1373 
    +          case break (== '\n') s of
    1374 
    +            (l, '\n':s'@(_:_)) -> (pre $ showLitString l "\\n\\") : go ('\\' :) s'
    1375 
    +            (l, '\n':[])       -> [pre $ showLitString l "\\n"]
    1376 
    +            (l, _)             -> [pre $ showLitString l ""]
    1377 
    +
    1378 
    +-- | Special combinator for showing multi-line string literals.
    1379 
    +pprHsStringMulti :: FastString -> SDoc
    1380 
    +pprHsStringMulti fs = text "\"\"\"" <> pprHsString' (unpackFS fs) <> text "\"\"\""
    1381 
    +
    1382 
    +-- | Like 'pprHsStringMulti' except without the outer quotes.
    1383 
    +pprHsStringMulti' :: String -> SDoc
    1384 
    +pprHsStringMulti' = vcat . map text . showLitStringMultiline
    1385 
    +  where
    1386 
    +    showLitChars :: String -> ShowS
    1387 
    +    showLitChars [] s = s
    1388 
    +    showLitChars (c : cs) s = showLitChar c (showLitChars cs s)
    1389 
    +
    1390 
    +    showLitStringMultiline :: String -> [String]
    1391 
    +    showLitStringMultiline = map (flip showLitChars "") . lines
    1361 1392
    1362 1393 
     -- | Special combinator for showing bytestring literals.
    1363 1394 
     pprHsBytes :: ByteString -> SDoc
    1364 1395 
     pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs
    1365 
    -                in vcat (map text (showMultiLineString escaped)) <> char '#'
    1396 
    +                in char '"' <> pprHsString' escaped <> text "\"#"
    1366 1397 
         where escape :: Word8 -> String
    1367 1398 
               escape w = let c = chr (fromIntegral w)
    1368 1399 
                          in if isAscii c

  • compiler/Language/Haskell/Syntax/StringMeta.hs
    1 
    +module Language.Haskell.Syntax.StringMeta (
    2 
    +  StringMeta (..),
    3 
    +  defaultStrMeta,
    4 
    +) where
    5 
    +
    6 
    +import Prelude
    7 
    +
    8 
    +import Language.Haskell.Syntax.Module.Name (ModuleName)
    9 
    +
    10 
    +-- libraries:
    11 
    +import Data.Data (Data)
    12 
    +
    13 
    +-- -----------------------------------------------------------------------------
    14 
    +-- StringMeta
    15 
    +
    16 
    +data StringMeta = StringMeta
    17 
    +  { strMetaMultiline  :: Bool
    18 
    +  , strMetaQualified  :: Maybe ModuleName
    19 
    +  }
    20 
    +  deriving (Show, Data)
    21 
    +
    22 
    +defaultStrMeta :: StringMeta
    23 
    +defaultStrMeta =
    24 
    +  StringMeta
    25 
    +    { strMetaMultiline = False
    26 
    +    , strMetaQualified = Nothing
    27 
    +    }

  • compiler/ghc.cabal.in
    ... ... @@ -1062,6 +1062,7 @@ Library
    1062 1062 
             Language.Haskell.Syntax.Module.Name
    1063 1063 
             Language.Haskell.Syntax.Pat
    1064 1064 
             Language.Haskell.Syntax.Specificity
    1065 
    +        Language.Haskell.Syntax.StringMeta
    1065 1066 
             Language.Haskell.Syntax.Text
    1066 1067 
             Language.Haskell.Syntax.Type
    1067 1068

  • testsuite/tests/count-deps/CountDepsAst.stdout
    ... ... @@ -28,5 +28,6 @@ Language.Haskell.Syntax.Lit
    28 28 
     Language.Haskell.Syntax.Module.Name
    29 29 
     Language.Haskell.Syntax.Pat
    30 30 
     Language.Haskell.Syntax.Specificity
    31 
    +Language.Haskell.Syntax.StringMeta
    31 32 
     Language.Haskell.Syntax.Text
    32 33 
     Language.Haskell.Syntax.Type

  • testsuite/tests/count-deps/CountDepsParser.stdout
    ... ... @@ -303,5 +303,6 @@ Language.Haskell.Syntax.Lit
    303 303 
     Language.Haskell.Syntax.Module.Name
    304 304 
     Language.Haskell.Syntax.Pat
    305 305 
     Language.Haskell.Syntax.Specificity
    306 
    +Language.Haskell.Syntax.StringMeta
    306 307 
     Language.Haskell.Syntax.Text
    307 308 
     Language.Haskell.Syntax.Type

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/compare/1dc1c81186579d245b2f3e3129154a99724baaed...deef7392d1714c8f579bdce1722969a91ea42b0a at 1789081938