{-# 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
intercalateMinimalStringGaps [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
  ParsedStringLiteral
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 :: Text -> [Text]
splitSegments = case ParsedStringLiteral -> StringLiteralKind
stringLiteralKind ParsedStringLiteral
psl of
        StringLiteralKind
RegularStringLiteral -> Text -> [Text]
splitGaps
        StringLiteralKind
MultilineStringLiteral -> Text -> [Text]
splitMultilineString
  ParsedStringLiteral -> Maybe ParsedStringLiteral
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParsedStringLiteral
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
      Text
suffix <- Text -> Text -> Maybe Text
T.stripPrefix Text
startMarker Text
s
      let markerWithHash :: Text
markerWithHash = Text
marker Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#"
      (Text
endMarker, Text
infix_) <-
        ((Text
markerWithHash,) (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
T.stripSuffix Text
markerWithHash Text
suffix)
          Maybe (Text, Text) -> Maybe (Text, Text) -> Maybe (Text, Text)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Text
marker,) (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
T.stripSuffix Text
marker Text
suffix)
      ParsedStringLiteral -> Maybe ParsedStringLiteral
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParsedStringLiteral {segments :: [Text]
segments = [Text
infix_], Text
StringLiteralKind
stringLiteralKind :: StringLiteralKind
endMarker :: Text
startMarker :: Text
stringLiteralKind :: StringLiteralKind
startMarker :: Text
endMarker :: Text
..}

    -- 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 just to
        -- emulate multi-line strings, so we replace them with "\\ \\".
        (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
intercalateMinimalStringGaps
        ([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

-- | Add minimal string gaps between string literal chunks. Such string gaps
-- /can/ be semantically meaningful (so we preserve them for simplicity); for
-- example:
--
-- >>> "\65\ \0" == "\650"
-- False
intercalateMinimalStringGaps :: [Text] -> Text
intercalateMinimalStringGaps :: [Text] -> Text
intercalateMinimalStringGaps = Text -> [Text] -> Text
T.intercalate Text
"\\ \\"