{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies      #-}

module Ide.PluginUtils
  ( -- * LSP Range manipulation functions
    normalize,
    extendNextLine,
    extendLineStart,
    extendToFullLines,
    WithDeletions(..),
    getProcessID,
    makeDiffTextEdit,
    makeDiffTextEditAdditive,
    diffText,
    diffText',
    pluginDescToIdePlugins,
    idePluginsToPluginDesc,
    getClientConfig,
    getPluginConfig,
    configForPlugin,
    pluginEnabled,
    extractTextInRange,
    fullRange,
    mkLspCommand,
    mkLspCmdId,
    getPid,
    allLspCmdIds,
    allLspCmdIds',
    installSigUsr1Handler,
    subRange,
    positionInRange,
    usePropertyLsp,
    -- * Escape
    unescape,
  )
where

import           Control.Arrow               ((&&&))
import           Control.Lens                (_head, _last, re, (%~), (^.))
import           Data.Algorithm.Diff
import           Data.Algorithm.DiffOutput
import           Data.Char                   (isPrint, showLitChar)
import           Data.Functor                (void)
import qualified Data.Map                    as M
import qualified Data.Text                   as T
import           Data.Void                   (Void)
import           Ide.Plugin.Config
import           Ide.Plugin.Properties
import           Ide.Types
import qualified Language.LSP.Protocol.Lens  as L
import           Language.LSP.Protocol.Types
import           Language.LSP.Server
import qualified Text.Megaparsec             as P
import qualified Text.Megaparsec.Char        as P
import qualified Text.Megaparsec.Char.Lexer  as P

-- ---------------------------------------------------------------------

-- | Extend to the line below and above to replace newline character.
--
-- >>> normalize (Range (Position 5 5) (Position 5 10))
-- Range (Position 5 0) (Position 6 0)
normalize :: Range -> Range
normalize :: Range -> Range
normalize = Range -> Range
extendLineStart forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> Range
extendNextLine

-- | Extend 'Range' to the start of the next line.
--
-- >>> extendNextLine (Range (Position 5 5) (Position 5 10))
-- Range (Position 5 5) (Position 6 0)
extendNextLine :: Range -> Range
extendNextLine :: Range -> Range
extendNextLine (Range Position
s (Position UInt
el UInt
_)) =
  Position -> Position -> Range
Range Position
s (UInt -> UInt -> Position
Position (UInt
el forall a. Num a => a -> a -> a
+ UInt
1) UInt
0)

-- | Extend 'Range' to the start of the current line.
--
-- >>> extendLineStart (Range (Position 5 5) (Position 5 10))
-- Range (Position 5 0) (Position 5 10)
extendLineStart :: Range -> Range
extendLineStart :: Range -> Range
extendLineStart (Range (Position UInt
sl UInt
_) Position
e) =
  Position -> Position -> Range
Range (UInt -> UInt -> Position
Position UInt
sl UInt
0) Position
e

-- | Extend 'Range' to include the start of the first line and start of the next line of the last line.
--
-- Caveat: It always extend the last line to the beginning of next line, even when the last position is at column 0.
-- This is to keep the compatibility with the implementation of old function @extractRange@.
--
-- >>> extendToFullLines (Range (Position 5 5) (Position 5 10))
-- Range (Position 5 0) (Position 6 0)
--
-- >>> extendToFullLines (Range (Position 5 5) (Position 7 2))
-- Range (Position 5 0) (Position 8 0)
--
-- >>> extendToFullLines (Range (Position 5 5) (Position 7 0))
-- Range (Position 5 0) (Position 8 0)
extendToFullLines :: Range -> Range
extendToFullLines :: Range -> Range
extendToFullLines = Range -> Range
extendLineStart forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> Range
extendNextLine


-- ---------------------------------------------------------------------

data WithDeletions = IncludeDeletions | SkipDeletions
  deriving (WithDeletions -> WithDeletions -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WithDeletions -> WithDeletions -> Bool
$c/= :: WithDeletions -> WithDeletions -> Bool
== :: WithDeletions -> WithDeletions -> Bool
$c== :: WithDeletions -> WithDeletions -> Bool
Eq)

-- | Generate a 'WorkspaceEdit' value from a pair of source Text
diffText :: ClientCapabilities -> (VersionedTextDocumentIdentifier, T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit
diffText :: ClientCapabilities
-> (VersionedTextDocumentIdentifier, Text)
-> Text
-> WithDeletions
-> WorkspaceEdit
diffText ClientCapabilities
clientCaps (VersionedTextDocumentIdentifier, Text)
old Text
new WithDeletions
withDeletions =
  let supports :: Bool
supports = ClientCapabilities -> Bool
clientSupportsDocumentChanges ClientCapabilities
clientCaps
   in Bool
-> (VersionedTextDocumentIdentifier, Text)
-> Text
-> WithDeletions
-> WorkspaceEdit
diffText' Bool
supports (VersionedTextDocumentIdentifier, Text)
old Text
new WithDeletions
withDeletions

makeDiffTextEdit :: T.Text -> T.Text -> [TextEdit]
makeDiffTextEdit :: Text -> Text -> [TextEdit]
makeDiffTextEdit Text
f1 Text
f2 = Text -> Text -> WithDeletions -> [TextEdit]
diffTextEdit Text
f1 Text
f2 WithDeletions
IncludeDeletions

makeDiffTextEditAdditive :: T.Text -> T.Text -> [TextEdit]
makeDiffTextEditAdditive :: Text -> Text -> [TextEdit]
makeDiffTextEditAdditive Text
f1 Text
f2 = Text -> Text -> WithDeletions -> [TextEdit]
diffTextEdit Text
f1 Text
f2 WithDeletions
SkipDeletions

diffTextEdit :: T.Text -> T.Text -> WithDeletions -> [TextEdit]
diffTextEdit :: Text -> Text -> WithDeletions -> [TextEdit]
diffTextEdit Text
fText Text
f2Text WithDeletions
withDeletions = [TextEdit]
r
  where
    r :: [TextEdit]
r = forall a b. (a -> b) -> [a] -> [b]
map DiffOperation LineRange -> TextEdit
diffOperationToTextEdit [DiffOperation LineRange]
diffOps
    d :: [Diff [String]]
d = forall a. Eq a => [a] -> [a] -> [Diff [a]]
getGroupedDiff (String -> [String]
lines forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
fText) (String -> [String]
lines forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
f2Text)

    diffOps :: [DiffOperation LineRange]
diffOps =
      forall a. (a -> Bool) -> [a] -> [a]
filter
        (\DiffOperation LineRange
x -> (WithDeletions
withDeletions forall a. Eq a => a -> a -> Bool
== WithDeletions
IncludeDeletions) Bool -> Bool -> Bool
|| Bool -> Bool
not (forall {a}. DiffOperation a -> Bool
isDeletion DiffOperation LineRange
x))
        ([Diff [String]] -> [DiffOperation LineRange]
diffToLineRanges [Diff [String]]
d)

    isDeletion :: DiffOperation a -> Bool
isDeletion (Deletion a
_ Int
_) = Bool
True
    isDeletion DiffOperation a
_              = Bool
False

    diffOperationToTextEdit :: DiffOperation LineRange -> TextEdit
    diffOperationToTextEdit :: DiffOperation LineRange -> TextEdit
diffOperationToTextEdit (Change LineRange
fm LineRange
to) = Range -> Text -> TextEdit
TextEdit Range
range Text
nt
      where
        range :: Range
range = LineRange -> Range
calcRange LineRange
fm
        nt :: Text
nt = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
init forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ LineRange -> [String]
lrContents LineRange
to

    {-
      In order to replace everything including newline characters,
      the end range should extend below the last line. From the specification:
      "If you want to specify a range that contains a line including
      the line ending character(s) then use an end position denoting
      the start of the next line"
    -}
    diffOperationToTextEdit (Deletion (LineRange (Int
sl, Int
el) [String]
_) Int
_) = Range -> Text -> TextEdit
TextEdit Range
range Text
""
      where
        range :: Range
range =
          Position -> Position -> Range
Range
            (UInt -> UInt -> Position
Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
sl forall a. Num a => a -> a -> a
- Int
1) UInt
0)
            (UInt -> UInt -> Position
Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
el) UInt
0)
    diffOperationToTextEdit (Addition LineRange
fm Int
l) = Range -> Text -> TextEdit
TextEdit Range
range Text
nt
      where
        -- fm has a range wrt to the changed file, which starts in the current file at l + 1
        -- So the range has to be shifted to start at l + 1

        range :: Range
range =
          Position -> Position -> Range
Range
            (UInt -> UInt -> Position
Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l) UInt
0)
            (UInt -> UInt -> Position
Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l) UInt
0)
        nt :: Text
nt = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ LineRange -> [String]
lrContents LineRange
fm

    calcRange :: LineRange -> Range
calcRange LineRange
fm = Position -> Position -> Range
Range Position
s Position
e
      where
        sl :: Int
sl = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ LineRange -> (Int, Int)
lrNumbers LineRange
fm
        sc :: UInt
sc = UInt
0
        s :: Position
s = UInt -> UInt -> Position
Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
sl forall a. Num a => a -> a -> a
- Int
1) UInt
sc -- Note: zero-based lines
        el :: Int
el = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ LineRange -> (Int, Int)
lrNumbers LineRange
fm
        ec :: UInt
ec = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last forall a b. (a -> b) -> a -> b
$ LineRange -> [String]
lrContents LineRange
fm
        e :: Position
e = UInt -> UInt -> Position
Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
el forall a. Num a => a -> a -> a
- Int
1) UInt
ec -- Note: zero-based lines

-- | A pure version of 'diffText' for testing
diffText' :: Bool -> (VersionedTextDocumentIdentifier, T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit
diffText' :: Bool
-> (VersionedTextDocumentIdentifier, Text)
-> Text
-> WithDeletions
-> WorkspaceEdit
diffText' Bool
supports (VersionedTextDocumentIdentifier
verTxtDocId, Text
fText) Text
f2Text WithDeletions
withDeletions =
  if Bool
supports
    then Maybe (Map Uri [TextEdit])
-> Maybe
     [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
-> WorkspaceEdit
WorkspaceEdit forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
docChanges) forall a. Maybe a
Nothing
    else Maybe (Map Uri [TextEdit])
-> Maybe
     [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
-> WorkspaceEdit
WorkspaceEdit (forall a. a -> Maybe a
Just Map Uri [TextEdit]
h) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
  where
    diff :: [TextEdit]
diff = Text -> Text -> WithDeletions -> [TextEdit]
diffTextEdit Text
fText Text
f2Text WithDeletions
withDeletions
    h :: Map Uri [TextEdit]
h = forall k a. k -> a -> Map k a
M.singleton (VersionedTextDocumentIdentifier
verTxtDocId forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
L.uri) [TextEdit]
diff
    docChanges :: [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
docChanges = [forall a b. a -> a |? b
InL TextDocumentEdit
docEdit]
    docEdit :: TextDocumentEdit
docEdit = OptionalVersionedTextDocumentIdentifier
-> [TextEdit |? AnnotatedTextEdit] -> TextDocumentEdit
TextDocumentEdit (VersionedTextDocumentIdentifier
verTxtDocId forall s a. s -> Getting a s a -> a
^. forall t b. AReview t b -> Getter b t
re Prism'
  OptionalVersionedTextDocumentIdentifier
  VersionedTextDocumentIdentifier
_versionedTextDocumentIdentifier) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> a |? b
InL [TextEdit]
diff

-- ---------------------------------------------------------------------

clientSupportsDocumentChanges :: ClientCapabilities -> Bool
clientSupportsDocumentChanges :: ClientCapabilities -> Bool
clientSupportsDocumentChanges ClientCapabilities
caps =
  let ClientCapabilities Maybe WorkspaceClientCapabilities
mwCaps Maybe TextDocumentClientCapabilities
_ Maybe NotebookDocumentClientCapabilities
_ Maybe WindowClientCapabilities
_ Maybe GeneralClientCapabilities
_ Maybe Value
_ = ClientCapabilities
caps
      supports :: Maybe Bool
supports = do
        WorkspaceClientCapabilities
wCaps <- Maybe WorkspaceClientCapabilities
mwCaps
        WorkspaceEditClientCapabilities Maybe Bool
mDc Maybe [ResourceOperationKind]
_ Maybe FailureHandlingKind
_ Maybe Bool
_ Maybe (Rec (("groupsOnLabel" .== Maybe Bool) .+ Empty))
_ <- WorkspaceClientCapabilities
-> Maybe WorkspaceEditClientCapabilities
_workspaceEdit WorkspaceClientCapabilities
wCaps
        Maybe Bool
mDc
   in forall a. a -> Maybe a
Just Bool
True forall a. Eq a => a -> a -> Bool
== Maybe Bool
supports

-- ---------------------------------------------------------------------

pluginDescToIdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState
pluginDescToIdePlugins :: forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
pluginDescToIdePlugins = forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
IdePlugins

idePluginsToPluginDesc :: IdePlugins ideState -> [PluginDescriptor ideState]
idePluginsToPluginDesc :: forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
idePluginsToPluginDesc (IdePlugins [PluginDescriptor ideState]
pp) = [PluginDescriptor ideState]
pp

-- ---------------------------------------------------------------------

-- | Returns the current client configuration. It is not wise to permanently
-- cache the returned value of this function, as clients can at runtime change
-- their configuration.
getClientConfig :: (MonadLsp Config m) => m Config
getClientConfig :: forall (m :: * -> *). MonadLsp Config m => m Config
getClientConfig = forall config (m :: * -> *). MonadLsp config m => m config
getConfig

-- ---------------------------------------------------------------------

-- | Returns the current plugin configuration. It is not wise to permanently
-- cache the returned value of this function, as clients can change their
-- configuration at runtime.
getPluginConfig :: (MonadLsp Config m) => PluginDescriptor c -> m PluginConfig
getPluginConfig :: forall (m :: * -> *) c.
MonadLsp Config m =>
PluginDescriptor c -> m PluginConfig
getPluginConfig PluginDescriptor c
plugin = do
  Config
config <- forall (m :: * -> *). MonadLsp Config m => m Config
getClientConfig
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
config PluginDescriptor c
plugin

-- ---------------------------------------------------------------------

-- | Returns the value of a property defined by the current plugin.
usePropertyLsp ::
  (HasProperty s k t r, MonadLsp Config m) =>
  KeyNameProxy s ->
  PluginDescriptor c ->
  Properties r ->
  m (ToHsType t)
usePropertyLsp :: forall (s :: Symbol) (k :: PropertyKey) (t :: PropertyType)
       (r :: [PropertyKey]) (m :: * -> *) c.
(HasProperty s k t r, MonadLsp Config m) =>
KeyNameProxy s
-> PluginDescriptor c -> Properties r -> m (ToHsType t)
usePropertyLsp KeyNameProxy s
kn PluginDescriptor c
pId Properties r
p = do
  PluginConfig
config <- forall (m :: * -> *) c.
MonadLsp Config m =>
PluginDescriptor c -> m PluginConfig
getPluginConfig PluginDescriptor c
pId
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (s :: Symbol) (k :: PropertyKey) (t :: PropertyType)
       (r :: [PropertyKey]).
HasProperty s k t r =>
KeyNameProxy s -> Properties r -> Object -> ToHsType t
useProperty KeyNameProxy s
kn Properties r
p forall a b. (a -> b) -> a -> b
$ PluginConfig -> Object
plcConfig PluginConfig
config

-- ---------------------------------------------------------------------

-- | Extracts exact matching text in the range.
extractTextInRange :: Range -> T.Text -> T.Text
extractTextInRange :: Range -> Text -> Text
extractTextInRange (Range (Position UInt
sl UInt
sc) (Position UInt
el UInt
ec)) Text
s = Text
newS
  where
    focusLines :: [Text]
focusLines =
      Text -> [Text]
T.lines Text
s
        -- NOTE: Always append an empty line to the end to ensure there are
        -- sufficient lines to take from.
        --
        -- There is a situation that when the end position is placed at the line
        -- below the last line, if we simply do `drop` and then `take`, there
        -- will be `el - sl` lines left, not `el - sl + 1` lines. And then
        -- the last line of code will be emptied unexpectedly.
        --
        -- For details, see https://github.com/haskell/haskell-language-server/issues/3847
        forall a b. a -> (a -> b) -> b
& (forall a. [a] -> [a] -> [a]
++ [Text
""])
        forall a b. a -> (a -> b) -> b
& forall a. Int -> [a] -> [a]
drop (forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
sl)
        forall a b. a -> (a -> b) -> b
& forall a. Int -> [a] -> [a]
take (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ UInt
el forall a. Num a => a -> a -> a
- UInt
sl forall a. Num a => a -> a -> a
+ UInt
1)
    -- NOTE: We have to trim the last line first to handle the single-line case
    newS :: Text
newS =
      [Text]
focusLines
        forall a b. a -> (a -> b) -> b
& forall s a. Snoc s s a a => Traversal' s a
_last forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> Text -> Text
T.take (forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
ec)
        forall a b. a -> (a -> b) -> b
& forall s a. Cons s s a a => Traversal' s a
_head forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> Text -> Text
T.drop (forall a b. (Integral a, Num b) => a -> b
fromIntegral UInt
sc)
        -- NOTE: We cannot use unlines here, because we don't want to add trailing newline!
        forall a b. a -> (a -> b) -> b
& Text -> [Text] -> Text
T.intercalate Text
"\n"

-- | Gets the range that covers the entire text
fullRange :: T.Text -> Range
fullRange :: Text -> Range
fullRange Text
s = Position -> Position -> Range
Range Position
startPos Position
endPos
  where
    startPos :: Position
startPos = UInt -> UInt -> Position
Position UInt
0 UInt
0
    endPos :: Position
endPos = UInt -> UInt -> Position
Position UInt
lastLine UInt
0
    {-
    In order to replace everything including newline characters,
    the end range should extend below the last line. From the specification:
    "If you want to specify a range that contains a line including
    the line ending character(s) then use an end position denoting
    the start of the next line"
    -}
    lastLine :: UInt
lastLine = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines Text
s

subRange :: Range -> Range -> Bool
subRange :: Range -> Range -> Bool
subRange = Range -> Range -> Bool
isSubrangeOf

-- ---------------------------------------------------------------------

allLspCmdIds' :: T.Text -> IdePlugins ideState -> [T.Text]
allLspCmdIds' :: forall ideState. Text -> IdePlugins ideState -> [Text]
allLspCmdIds' Text
pid (IdePlugins [PluginDescriptor ideState]
ls) =
  forall ideState.
Text -> [(PluginId, [PluginCommand ideState])] -> [Text]
allLspCmdIds Text
pid forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall ideState. PluginDescriptor ideState -> PluginId
pluginId forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall ideState.
PluginDescriptor ideState -> [PluginCommand ideState]
pluginCommands) [PluginDescriptor ideState]
ls

allLspCmdIds :: T.Text -> [(PluginId, [PluginCommand ideState])] -> [T.Text]
allLspCmdIds :: forall ideState.
Text -> [(PluginId, [PluginCommand ideState])] -> [Text]
allLspCmdIds Text
pid [(PluginId, [PluginCommand ideState])]
commands = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PluginId, [PluginCommand ideState]) -> [Text]
go [(PluginId, [PluginCommand ideState])]
commands
  where
    go :: (PluginId, [PluginCommand ideState]) -> [Text]
go (PluginId
plid, [PluginCommand ideState]
cmds) = forall a b. (a -> b) -> [a] -> [b]
map (Text -> PluginId -> CommandId -> Text
mkLspCmdId Text
pid PluginId
plid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ideState. PluginCommand ideState -> CommandId
commandId) [PluginCommand ideState]
cmds

-- ---------------------------------------------------------------------


type TextParser = P.Parsec Void T.Text

-- | Unescape printable escape sequences within double quotes.
-- This is useful if you have to call 'show' indirectly, and it escapes some characters which you would prefer to
-- display as is.
unescape :: T.Text -> T.Text
unescape :: Text -> Text
unescape Text
input =
  case forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
P.runParser TextParser String
escapedTextParser String
"inline" Text
input of
    Left ParseErrorBundle Text Void
_     -> Text
input
    Right String
strs -> String -> Text
T.pack String
strs

-- | Parser for a string that contains double quotes. Returns unescaped string.
escapedTextParser :: TextParser String
escapedTextParser :: TextParser String
escapedTextParser = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many (TextParser String
outsideStringLiteral forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
P.<|> TextParser String
stringLiteral)
  where
    outsideStringLiteral :: TextParser String
    outsideStringLiteral :: TextParser String
outsideStringLiteral = forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
P.someTill (forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
P.anySingleBut Char
'"') (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
P.lookAhead (forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'"') forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
P.<|> forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof))

    stringLiteral :: TextParser String
    stringLiteral :: TextParser String
stringLiteral = do
      String
inside <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'"' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
P.manyTill forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
P.charLiteral (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'"')
      let f :: Char -> String
f Char
'"' = String
"\\\"" -- double quote should still be escaped
      -- Despite the docs, 'showLitChar' and 'showLitString' from 'Data.Char' DOES ESCAPE unicode printable
      -- characters. So we need to call 'isPrint' from 'Data.Char' manually.
          f Char
ch  = if Char -> Bool
isPrint Char
ch then [Char
ch] else Char -> ShowS
showLitChar Char
ch String
""
          inside' :: String
inside' = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
f String
inside

      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
"\"" forall a. Semigroup a => a -> a -> a
<> String
inside' forall a. Semigroup a => a -> a -> a
<> String
"\""