{-# LANGUAGE OverloadedStrings #-}

module ShellWords
    ( parse
    , parseText

    -- * Low-level parser
    , Parser
    , runParser
    , parser
    ) where

import Prelude

import Data.Bifunctor (first)
import Data.Char
import Data.List (dropWhileEnd)
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack, unpack)
import Data.Void (Void)
import qualified Text.Megaparsec as Megaparsec
import Text.Megaparsec.Char
import Text.Megaparsec.Compat hiding (parse, runParser)

type Parser = Parsec Void String

parse :: String -> Either String [String]
parse :: String -> Either String [String]
parse = Parser [String] -> String -> Either String [String]
forall a. Parser a -> String -> Either String a
runParser Parser [String]
parser

runParser :: Parser a -> String -> Either String a
runParser :: Parser a -> String -> Either String a
runParser Parser a
p = (ParseErrorBundle String Void -> String)
-> Either (ParseErrorBundle String Void) a -> Either String a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty (Either (ParseErrorBundle String Void) a -> Either String a)
-> (String -> Either (ParseErrorBundle String Void) a)
-> String
-> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a
-> String -> String -> Either (ParseErrorBundle String Void) a
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
Megaparsec.parse Parser a
p String
"<input>"

-- | Parse and return @'Text'@ values
parseText :: Text -> Either String [Text]
parseText :: Text -> Either String [Text]
parseText = ([String] -> [Text])
-> Either String [String] -> Either String [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
pack) (Either String [String] -> Either String [Text])
-> (Text -> Either String [String]) -> Text -> Either String [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String [String]
parse (String -> Either String [String])
-> (Text -> String) -> Text -> Either String [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack

parser :: Parser [String]
parser :: Parser [String]
parser = ([String] -> [String]) -> Parser [String] -> Parser [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (Parser [String] -> Parser [String])
-> Parser [String] -> Parser [String]
forall a b. (a -> b) -> a -> b
$ ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space ParsecT Void String Identity ()
-> Parser [String] -> Parser [String]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser String
shellword Parser String -> ParsecT Void String Identity () -> Parser [String]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepEndBy1` ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1

shellword :: Parser String
shellword :: Parser String
shellword =
    [Parser String] -> Parser String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
            [ Parser String
quoted Parser String -> String -> Parser String
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"quoted string"
            , Parser String
shelloption Parser String -> String -> Parser String
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"shell option"
            , Parser String
value Parser String -> String -> Parser String
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"bare value"
            ]
        Parser String -> String -> Parser String
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"shell word"

-- | A balanced, single- or double-quoted string
quoted :: Parser String
quoted :: Parser String
quoted = do
    Char
q <- [Token String] -> ParsecT Void String Identity (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf [Char
'\'', Char
'\"']
    ParsecT Void String Identity Char
-> ParsecT Void String Identity Char -> Parser String
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
manyTill (Char -> ParsecT Void String Identity Char
escaped Char
q ParsecT Void String Identity Char
-> ParsecT Void String Identity Char
-> ParsecT Void String Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void String Identity Char
anyToken) (ParsecT Void String Identity Char -> Parser String)
-> ParsecT Void String Identity Char -> Parser String
forall a b. (a -> b) -> a -> b
$ Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
q

-- | A flag, with or without an argument
shelloption :: Parser String
shelloption :: Parser String
shelloption = String -> String -> String
forall a. Semigroup a => a -> a -> a
(<>) (String -> String -> String)
-> Parser String -> ParsecT Void String Identity (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
flag ParsecT Void String Identity (String -> String)
-> Parser String -> Parser String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String)
-> ParsecT Void String Identity (Maybe String) -> Parser String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String -> ParsecT Void String Identity (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser String
argument)

-- brittany-disable-next-binding

-- | A flag like @--foo@, or (apparently) @--\"baz bat\"@
flag :: Parser String
flag :: Parser String
flag =
    String -> String -> String
forall a. Semigroup a => a -> a -> a
(<>)
        (String -> String -> String)
-> Parser String -> ParsecT Void String Identity (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
"--" Parser String -> Parser String -> Parser String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
"-")
        ParsecT Void String Identity (String -> String)
-> Parser String -> Parser String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser String
quoted Parser String -> Parser String -> Parser String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser String
value)

-- | The argument to a flag like @=foo@, or @=\"baz bat\"@
argument :: Parser String
argument :: Parser String
argument = (:) (Char -> String -> String)
-> ParsecT Void String Identity Char
-> ParsecT Void String Identity (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'=' ParsecT Void String Identity (String -> String)
-> Parser String -> Parser String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser String
quoted Parser String -> Parser String -> Parser String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser String
value)

-- | A plain value, here till an (unescaped) space
value :: Parser String
value :: Parser String
value = ParsecT Void String Identity Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void String Identity Char
nonSpaceNonReserved

escaped :: Char -> Parser Char
escaped :: Char -> ParsecT Void String Identity Char
escaped Char
c = Char
c Char
-> ParsecT Void String Identity Char
-> ParsecT Void String Identity Char
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ((Char -> Bool) -> ParsecT Void String Identity Char
escapedSatisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) ParsecT Void String Identity Char
-> String -> ParsecT Void String Identity Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"escaped" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Char -> String
forall a. Show a => a -> String
show Char
c)

escapedSpace :: Parser Char
escapedSpace :: ParsecT Void String Identity Char
escapedSpace = (Char -> Bool) -> ParsecT Void String Identity Char
escapedSatisfy Char -> Bool
isSpace ParsecT Void String Identity Char
-> String -> ParsecT Void String Identity Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"escaped white space"

escapedAnyOf :: [Char] -> Parser Char
escapedAnyOf :: String -> ParsecT Void String Identity Char
escapedAnyOf String
cs = (Char -> Bool) -> ParsecT Void String Identity Char
escapedSatisfy (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
cs) ParsecT Void String Identity Char
-> String -> ParsecT Void String Identity Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"escaped one of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cs

escapedSatisfy :: (Char -> Bool) -> Parser Char
escapedSatisfy :: (Char -> Bool) -> ParsecT Void String Identity Char
escapedSatisfy Char -> Bool
p = ParsecT Void String Identity Char
-> ParsecT Void String Identity Char
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void String Identity Char
 -> ParsecT Void String Identity Char)
-> ParsecT Void String Identity Char
-> ParsecT Void String Identity Char
forall a b. (a -> b) -> a -> b
$ Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
"\\" Parser String
-> ParsecT Void String Identity Char
-> ParsecT Void String Identity Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Token String -> Bool)
-> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token String -> Bool
p

anyToken :: Parser Char
anyToken :: ParsecT Void String Identity Char
anyToken = (Token String -> Bool)
-> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy ((Token String -> Bool)
 -> ParsecT Void String Identity (Token String))
-> (Token String -> Bool)
-> ParsecT Void String Identity (Token String)
forall a b. (a -> b) -> a -> b
$ Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True

nonSpaceNonReserved :: Parser Char
nonSpaceNonReserved :: ParsecT Void String Identity Char
nonSpaceNonReserved =
    ParsecT Void String Identity Char
escapedSpace
        ParsecT Void String Identity Char
-> ParsecT Void String Identity Char
-> ParsecT Void String Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> ParsecT Void String Identity Char
escapedAnyOf String
reserved
        ParsecT Void String Identity Char
-> ParsecT Void String Identity Char
-> ParsecT Void String Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Token String -> Bool)
-> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (\Token String
c -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isSpace Char
Token String
c Bool -> Bool -> Bool
|| Char -> Bool
isReserved Char
Token String
c)
        ParsecT Void String Identity Char
-> String -> ParsecT Void String Identity Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"non white space / non reserved character"

isReserved :: Char -> Bool
isReserved :: Char -> Bool
isReserved = (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
reserved)

reserved :: [Char]
reserved :: String
reserved = String
"();="