{-# LANGUAGE OverloadedStrings #-}

module ShellWords.Parse
  ( -- * Splitting shell words
    parse
  , parseText

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

import Prelude

import Data.Bifunctor (first)
import Data.Char
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 :: [Char] -> Either [Char] [[Char]]
parse = Parser [[Char]] -> [Char] -> Either [Char] [[Char]]
forall a. Parser a -> [Char] -> Either [Char] a
runParser Parser [[Char]]
parser

runParser :: Parser a -> String -> Either String a
runParser :: forall a. Parser a -> [Char] -> Either [Char] a
runParser Parser a
p = (ParseErrorBundle [Char] Void -> [Char])
-> Either (ParseErrorBundle [Char] Void) a -> Either [Char] a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle [Char] Void -> [Char]
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> [Char]
errorBundlePretty (Either (ParseErrorBundle [Char] Void) a -> Either [Char] a)
-> ([Char] -> Either (ParseErrorBundle [Char] Void) a)
-> [Char]
-> Either [Char] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a
-> [Char] -> [Char] -> Either (ParseErrorBundle [Char] Void) a
forall e s a.
Parsec e s a -> [Char] -> s -> Either (ParseErrorBundle s e) a
Megaparsec.parse (Parser a
p Parser a -> ParsecT Void [Char] Identity () -> Parser a
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void [Char] Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) [Char]
"<input>"

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

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

shellword :: Parser String
shellword :: Parser [Char]
shellword = ([[Char]] -> [Char]) -> Parser [[Char]] -> Parser [Char]
forall a b.
(a -> b)
-> ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Parser [[Char]] -> Parser [Char])
-> Parser [[Char]] -> Parser [Char]
forall a b. (a -> b) -> a -> b
$ Parser [Char] -> Parser [[Char]]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (Parser [Char] -> Parser [[Char]])
-> Parser [Char] -> Parser [[Char]]
forall a b. (a -> b) -> a -> b
$ Parser [Char]
bare Parser [Char] -> Parser [Char] -> Parser [Char]
forall a.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [Char]
quoted

-- | A plain value, here till an (unescaped) space or quote
bare :: Parser String
bare :: Parser [Char]
bare = ParsecT Void [Char] Identity Char -> Parser [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void [Char] Identity Char
go
 where
  go :: ParsecT Void [Char] Identity Char
go =
    Char -> ParsecT Void [Char] Identity Char
escaped Char
'\\'
      ParsecT Void [Char] Identity Char
-> ParsecT Void [Char] Identity Char
-> ParsecT Void [Char] Identity Char
forall a.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void [Char] Identity Char
escapedSpace
      ParsecT Void [Char] Identity Char
-> ParsecT Void [Char] Identity Char
-> ParsecT Void [Char] Identity Char
forall a.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Char] -> ParsecT Void [Char] Identity Char
escapedAnyOf ([Char]
reserved [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
quotes)
      ParsecT Void [Char] Identity Char
-> ParsecT Void [Char] Identity Char
-> ParsecT Void [Char] Identity Char
forall a.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity a -> ParsecT Void [Char] Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Token [Char] -> Bool)
-> ParsecT Void [Char] Identity (Token [Char])
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool) -> (Char -> Bool) -> Char -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace (Char -> Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall a b. (Char -> a -> b) -> (Char -> a) -> Char -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([Char]
reserved [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
quotes)))
      ParsecT Void [Char] Identity Char
-> [Char] -> ParsecT Void [Char] Identity Char
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"non white space / non reserved character / non quote"

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

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

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

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

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

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

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

quotes :: [Char]
quotes :: [Char]
quotes = [Char]
"\'\""