    {-# LANGUAGE BlockArguments #-}
    {-# LANGUAGE DerivingStrategies #-}
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE ViewPatterns #-}

    module Ormolu.Printer.Meat.Declaration.StringLiteral (p_stringLit) where

    import Control.Applicative (Alternative (..))
    import Control.Category ((>>>))
    import Control.Monad ((>=>))
    import Data.Semigroup (Min (..))
    import Data.Text (Text)
    import Data.Text qualified as T
    import GHC.Data.FastString
    import GHC.Parser.CharClass (is_space)
    import Ormolu.Printer.Combinators
    import Ormolu.Utils

    -- | Print the source text of a string literal while indenting gaps and newlines
    -- correctly.
    p_stringLit :: FastString -> R ()
    p_stringLit :: FastString -> R ()
    p_stringLit FastString
    src = case Text -> Maybe ParsedStringLiteral
    parseStringLiteral (Text -> Maybe ParsedStringLiteral)
    -> Text -> Maybe ParsedStringLiteral
    forall a b. (a -> b) -> a -> b
    $ [Char] -> Text
    T.pack ([Char] -> Text) -> [Char] -> Text
    forall a b. (a -> b) -> a -> b
    $ FastString -> [Char]
    unpackFS FastString
    src of
      Maybe ParsedStringLiteral
    Nothing -> [Char] -> R ()
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> R ()) -> [Char] -> R ()
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "Internal Ormolu error: couldn't parse string literal: " [Char] -> [Char] -> [Char]
    forall a. Semigroup a => a -> a -> a
    <> FastString -> [Char]
    forall a. Show a => a -> [Char]
    show FastString
    src
      Just ParsedStringLiteral {[Text]
    Text
    StringLiteralKind
    startMarker :: Text
    endMarker :: Text
    stringLiteralKind :: StringLiteralKind
    segments :: [Text]
    segments :: ParsedStringLiteral -> [Text]
    stringLiteralKind :: ParsedStringLiteral -> StringLiteralKind
    endMarker :: ParsedStringLiteral -> Text
    startMarker :: ParsedStringLiteral -> Text
    ..} -> R () -> R ()
    sitcc do
        Text -> R ()
    txt Text
    startMarker
        case StringLiteralKind
    stringLiteralKind of
          StringLiteralKind
    RegularStringLiteral -> do
            let singleLine :: R ()
    singleLine =
                  Text -> R ()
    txt (Text -> R ()) -> Text -> R ()
    forall a b. (a -> b) -> a -> b
    $ [Text] -> Text
    T.concat [Text]
    segments
                multiLine :: R ()
    multiLine =
                  R ()
    -> ((RelativePos, Text) -> R ()) -> [(RelativePos, Text)] -> R ()
    forall a. R () -> (a -> R ()) -> [a] -> R ()
    sep R ()
    breakpoint (RelativePos, Text) -> R ()
    f ([Text] -> [(RelativePos, Text)]
    forall a. [a] -> [(RelativePos, a)]
    attachRelativePos [Text]
    segments)
                  where
                    f :: (RelativePos, Text) -> R ()
                    f :: (RelativePos, Text) -> R ()
    f (RelativePos
    pos, Text
    s) = case RelativePos
    pos of
                      RelativePos
    SinglePos -> Text -> R ()
    txt Text
    s
                      RelativePos
    FirstPos -> Text -> R ()
    txt Text
    s R () -> R () -> R ()
    forall a b. R a -> R b -> R b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> Text -> R ()
    txt Text
    "\\"
                      RelativePos
    MiddlePos -> Text -> R ()
    txt Text
    "\\" R () -> R () -> R ()
    forall a b. R a -> R b -> R b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> Text -> R ()
    txt Text
    s R () -> R () -> R ()
    forall a b. R a -> R b -> R b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> Text -> R ()
    txt Text
    "\\"
                      RelativePos
    LastPos -> Text -> R ()
    txt Text
    "\\" R () -> R () -> R ()
    forall a b. R a -> R b -> R b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> Text -> R ()
    txt Text
    s
            R () -> R () -> R ()
    forall a. R a -> R a -> R a
    vlayout R ()
    singleLine R ()
    multiLine
          StringLiteralKind
    MultilineStringLiteral ->
            R () -> (Text -> R ()) -> [Text] -> R ()
    forall a. R () -> (a -> R ()) -> [a] -> R ()
    sep R ()
    breakpoint' Text -> R ()
    txt [Text]
    segments
        Text -> R ()
    txt Text
    endMarker

    -- | The start/end marker of the literal, whether it is a regular or a multiline
    -- literal, and the segments of the literals (separated by gaps for a regular
    -- literal, and separated by newlines for a multiline literal).
    data ParsedStringLiteral = ParsedStringLiteral
      { ParsedStringLiteral -> Text
    startMarker, ParsedStringLiteral -> Text
    endMarker :: Text,
        ParsedStringLiteral -> StringLiteralKind
    stringLiteralKind :: StringLiteralKind,
        ParsedStringLiteral -> [Text]
    segments :: [Text]
      }
      deriving stock (Int -> ParsedStringLiteral -> [Char] -> [Char]
    [ParsedStringLiteral] -> [Char] -> [Char]
    ParsedStringLiteral -> [Char]
    (Int -> ParsedStringLiteral -> [Char] -> [Char])
    -> (ParsedStringLiteral -> [Char])
    -> ([ParsedStringLiteral] -> [Char] -> [Char])
    -> Show ParsedStringLiteral
    forall a.
    (Int -> a -> [Char] -> [Char])
    -> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
    $cshowsPrec :: Int -> ParsedStringLiteral -> [Char] -> [Char]
    showsPrec :: Int -> ParsedStringLiteral -> [Char] -> [Char]
    $cshow :: ParsedStringLiteral -> [Char]
    show :: ParsedStringLiteral -> [Char]
    $cshowList :: [ParsedStringLiteral] -> [Char] -> [Char]
    showList :: [ParsedStringLiteral] -> [Char] -> [Char]
    Show, ParsedStringLiteral -> ParsedStringLiteral -> Bool
    (ParsedStringLiteral -> ParsedStringLiteral -> Bool)
    -> (ParsedStringLiteral -> ParsedStringLiteral -> Bool)
    -> Eq ParsedStringLiteral
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: ParsedStringLiteral -> ParsedStringLiteral -> Bool
    == :: ParsedStringLiteral -> ParsedStringLiteral -> Bool
    $c/= :: ParsedStringLiteral -> ParsedStringLiteral -> Bool
    /= :: ParsedStringLiteral -> ParsedStringLiteral -> Bool
    Eq)

    -- | A regular or a multiline string literal.
    data StringLiteralKind = RegularStringLiteral | MultilineStringLiteral
      deriving stock (Int -> StringLiteralKind -> [Char] -> [Char]
    [StringLiteralKind] -> [Char] -> [Char]
    StringLiteralKind -> [Char]
    (Int -> StringLiteralKind -> [Char] -> [Char])
    -> (StringLiteralKind -> [Char])
    -> ([StringLiteralKind] -> [Char] -> [Char])
    -> Show StringLiteralKind
    forall a.
    (Int -> a -> [Char] -> [Char])
    -> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
    $cshowsPrec :: Int -> StringLiteralKind -> [Char] -> [Char]
    showsPrec :: Int -> StringLiteralKind -> [Char] -> [Char]
    $cshow :: StringLiteralKind -> [Char]
    show :: StringLiteralKind -> [Char]
    $cshowList :: [StringLiteralKind] -> [Char] -> [Char]
    showList :: [StringLiteralKind] -> [Char] -> [Char]
    Show, StringLiteralKind -> StringLiteralKind -> Bool
    (StringLiteralKind -> StringLiteralKind -> Bool)
    -> (StringLiteralKind -> StringLiteralKind -> Bool)
    -> Eq StringLiteralKind
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: StringLiteralKind -> StringLiteralKind -> Bool
    == :: StringLiteralKind -> StringLiteralKind -> Bool
    $c/= :: StringLiteralKind -> StringLiteralKind -> Bool
    /= :: StringLiteralKind -> StringLiteralKind -> Bool
    Eq)

    -- | Turn a string literal (as it exists in the source) into a more structured
    -- form for printing. This should never return 'Nothing' for literals that the
    -- GHC parser accepted.
    parseStringLiteral :: Text -> Maybe ParsedStringLiteral
    parseStringLiteral :: Text -> Maybe ParsedStringLiteral
    parseStringLiteral = \Text
    s -> do
      psl <-
        (StringLiteralKind -> Text -> Text -> Maybe ParsedStringLiteral
    stripStartEndMarker StringLiteralKind
    MultilineStringLiteral Text
    "\"\"\"" Text
    s)
          Maybe ParsedStringLiteral
    -> Maybe ParsedStringLiteral -> Maybe ParsedStringLiteral
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> (StringLiteralKind -> Text -> Text -> Maybe ParsedStringLiteral
    stripStartEndMarker StringLiteralKind
    RegularStringLiteral Text
    "\"" Text
    s)
      let splitSegments = case ParsedStringLiteral -> StringLiteralKind
    stringLiteralKind ParsedStringLiteral
    psl of
            StringLiteralKind
    RegularStringLiteral -> Text -> [Text]
    splitGaps
            StringLiteralKind
    MultilineStringLiteral -> Text -> [Text]
    splitMultilineString
      pure psl {segments = concatMap splitSegments $ segments psl}
      where
        -- Remove the given marker from the start and the end (at the end,
        -- optionally also remove a #).
        stripStartEndMarker ::
          StringLiteralKind -> Text -> Text -> Maybe ParsedStringLiteral
        stripStartEndMarker :: StringLiteralKind -> Text -> Text -> Maybe ParsedStringLiteral
    stripStartEndMarker StringLiteralKind
    stringLiteralKind Text
    marker Text
    s = do
          let startMarker :: Text
    startMarker = Text
    marker
          suffix <- Text -> Text -> Maybe Text
    T.stripPrefix Text
    startMarker Text
    s
          let markerWithHash = Text
    marker Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "#"
          (endMarker, infix_) <-
            ((markerWithHash,) <$> T.stripSuffix markerWithHash suffix)
              <|> ((marker,) <$> T.stripSuffix marker suffix)
          pure ParsedStringLiteral {segments = [infix_], ..}

        -- Split a string on gaps (backslash delimited whitespaces).
        --
        -- > splitGaps "bar\\  \\fo\\&o" == ["bar", "fo\\&o"]
        splitGaps :: Text -> [Text]
        splitGaps :: Text -> [Text]
    splitGaps Text
    s = [(Text, Text)] -> [Text]
    go ([(Text, Text)] -> [Text]) -> [(Text, Text)] -> [Text]
    forall a b. (a -> b) -> a -> b
    $ HasCallStack => Text -> Text -> [(Text, Text)]
    Text -> Text -> [(Text, Text)]
    T.breakOnAll Text
    "\\" Text
    s
          where
            go :: [(Text, Text)] -> [Text]
    go [] = [Text
    s]
            go ((Text
    pre, Text
    suf) : [(Text, Text)]
    bs) = case Text -> Maybe (Char, Text)
    T.uncons Text
    suf of
              Just (Char
    '\\', Text -> Maybe (Char, Text)
    T.uncons -> Just (Char
    c, Text
    s'))
                | Char -> Bool
    is_space Char
    c,
                  let rest :: Text
    rest = Int -> Text -> Text
    T.drop Int
    1 (Text -> Text) -> Text -> Text
    forall a b. (a -> b) -> a -> b
    $ (Char -> Bool) -> Text -> Text
    T.dropWhile (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '\\') Text
    s' ->
                    Text
    pre Text -> [Text] -> [Text]
    forall a. a -> [a] -> [a]
    : Text -> [Text]
    splitGaps Text
    rest
                | Bool
    otherwise -> [(Text, Text)] -> [Text]
    go ([(Text, Text)] -> [Text]) -> [(Text, Text)] -> [Text]
    forall a b. (a -> b) -> a -> b
    $ (if Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '\\' then Int -> [(Text, Text)] -> [(Text, Text)]
    forall a. Int -> [a] -> [a]
    drop Int
    1 else [(Text, Text)] -> [(Text, Text)]
    forall a. a -> a
    id) [(Text, Text)]
    bs
              Maybe (Char, Text)
    _ -> [(Text, Text)] -> [Text]
    go [(Text, Text)]
    bs

        -- See the the MultilineStrings GHC proposal and 'lexMultilineString' from
        -- "GHC.Parser.String" for reference.
        --
        -- https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0569-multiline-strings.rst#proposed-change-specification
        splitMultilineString :: Text -> [Text]
        splitMultilineString :: Text -> [Text]
    splitMultilineString =
          Text -> [Text]
    splitGaps
            -- There is no reason to use gaps with multiline string literals, so
            -- we collapse them.
            (Text -> [Text]) -> ([Text] -> [Text]) -> Text -> [Text]
    forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> [Text] -> Text
    T.concat
            ([Text] -> Text) -> (Text -> [Text]) -> [Text] -> [Text]
    forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> Text -> [Text]
    splitNewlines
            (Text -> [Text]) -> ([Text] -> [Text]) -> Text -> [Text]
    forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> (Text -> Text) -> [Text] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Text -> Text
    expandLeadingTabs
            ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
    forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> [Text] -> [Text]
    rmCommonWhitespacePrefixAndBlank

        -- See the definition of newlines on
        -- <https://www.haskell.org/onlinereport/haskell2010/haskellch10.html#x17-17800010.3>.
        splitNewlines :: Text -> [Text]
        splitNewlines :: Text -> [Text]
    splitNewlines = HasCallStack => Text -> Text -> [Text]
    Text -> Text -> [Text]
    T.splitOn Text
    "\r\n" (Text -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
    forall (m :: * -> *) a b c.
    Monad m =>
    (a -> m b) -> (b -> m c) -> a -> m c
    >=> (Char -> Bool) -> Text -> [Text]
    T.split Char -> Bool
    isNewlineish
          where
            isNewlineish :: Char -> Bool
    isNewlineish Char
    c = Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '\n' Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '\r' Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '\f'

        -- See GHC's 'lexMultilineString'.
        expandLeadingTabs :: Text -> Text
        expandLeadingTabs :: Text -> Text
    expandLeadingTabs = [Text] -> Text
    T.concat ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> Text -> [Text]
    go Int
    0
          where
            go :: Int -> Text -> [Text]
            go :: Int -> Text -> [Text]
    go Int
    col Text
    s = case HasCallStack => Text -> Text -> (Text, Text)
    Text -> Text -> (Text, Text)
    T.breakOn Text
    "\t" Text
    s of
              (Text
    pre, Text -> Maybe (Char, Text)
    T.uncons -> Just (Char
    _, Text
    suf)) ->
                let col' :: Int
    col' = Int
    col Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Text -> Int
    T.length Text
    pre
                    fill :: Int
    fill = Int
    8 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - (Int
    col' Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `mod` Int
    8)
                 in Text
    pre Text -> [Text] -> [Text]
    forall a. a -> [a] -> [a]
    : Int -> Text -> Text
    T.replicate Int
    fill Text
    " " Text -> [Text] -> [Text]
    forall a. a -> [a] -> [a]
    : Int -> Text -> [Text]
    go (Int
    col' Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    fill) Text
    suf
              (Text, Text)
    _ -> [Text
    s]

        -- Don't touch the first line, and remove common whitespace from all
        -- remaining lines as well as convert those consisting only of whitespace to
        -- empty lines.
        rmCommonWhitespacePrefixAndBlank :: [Text] -> [Text]
        rmCommonWhitespacePrefixAndBlank :: [Text] -> [Text]
    rmCommonWhitespacePrefixAndBlank = \case
          [] -> []
          Text
    hd : [Text]
    tl -> Text
    hd Text -> [Text] -> [Text]
    forall a. a -> [a] -> [a]
    : [Text]
    tl'
            where
              ([Maybe (Min Int)]
    leadingSpaces, [Text]
    tl') = [(Maybe (Min Int), Text)] -> ([Maybe (Min Int)], [Text])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ([(Maybe (Min Int), Text)] -> ([Maybe (Min Int)], [Text]))
    -> [(Maybe (Min Int), Text)] -> ([Maybe (Min Int)], [Text])
    forall a b. (a -> b) -> a -> b
    $ Text -> (Maybe (Min Int), Text)
    countLeadingAndBlank (Text -> (Maybe (Min Int), Text))
    -> [Text] -> [(Maybe (Min Int), Text)]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [Text]
    tl

              commonWs :: Int
              commonWs :: Int
    commonWs = Int -> (Min Int -> Int) -> Maybe (Min Int) -> Int
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Int
    0 Min Int -> Int
    forall a. Min a -> a
    getMin (Maybe (Min Int) -> Int) -> Maybe (Min Int) -> Int
    forall a b. (a -> b) -> a -> b
    $ [Maybe (Min Int)] -> Maybe (Min Int)
    forall a. Monoid a => [a] -> a
    mconcat [Maybe (Min Int)]
    leadingSpaces

              countLeadingAndBlank :: Text -> (Maybe (Min Int), Text)
              countLeadingAndBlank :: Text -> (Maybe (Min Int), Text)
    countLeadingAndBlank Text
    l
                | (Char -> Bool) -> Text -> Bool
    T.all Char -> Bool
    is_space Text
    l = (Maybe (Min Int)
    forall a. Maybe a
    Nothing, Text
    "")
                | Bool
    otherwise = (Min Int -> Maybe (Min Int)
    forall a. a -> Maybe a
    Just (Min Int -> Maybe (Min Int)) -> Min Int -> Maybe (Min Int)
    forall a b. (a -> b) -> a -> b
    $ Int -> Min Int
    forall a. a -> Min a
    Min Int
    leadingSpace, Int -> Text -> Text
    T.drop Int
    commonWs Text
    l)
                where
                  leadingSpace :: Int
    leadingSpace = Text -> Int
    T.length (Text -> Int) -> Text -> Int
    forall a b. (a -> b) -> a -> b
    $ (Char -> Bool) -> Text -> Text
    T.takeWhile Char -> Bool
    is_space Text
    l