{-# LANGUAGE OverloadedStrings #-}
module ShellWords
( parse
) where
import Data.Bifunctor (first)
import Data.Char
import Data.Semigroup ((<>))
import Data.Text (Text)
import Data.Text as T
import Data.Void (Void)
import Text.Megaparsec hiding (parse)
import qualified Text.Megaparsec as Megaparsec
import Text.Megaparsec.Char
type Parser = Parsec Void Text
parse :: Text -> Either String [Text]
parse = first parseErrorPretty . Megaparsec.parse parser "<input>"
parser :: Parser [Text]
parser = shellword `sepBy` space1
shellword :: Parser Text
shellword = choice
[ quoted
, try quotedFlag
, flagArgument
, value
]
quoted :: Parser Text
quoted = do
q <- oneOf ['\'', '\"']
T.pack <$> manyTill (try (escaped q) <|> anyToken) (char q)
quotedFlag :: Parser Text
quotedFlag = (<>)
<$> flagPrefix
<*> quoted
flagArgument :: Parser Text
flagArgument = concat4
<$> flagPrefix
<*> (T.pack <$> manyTill anyToken (char '='))
<*> pure "="
<*> (quoted <|> value)
where
concat4 a b c d = a <> b <> c <> d
flagPrefix :: Parser Text
flagPrefix = string "--" <|> string "-"
value :: Parser Text
value = T.pack <$> many (try (escaped ' ') <|> nonSpace)
escaped :: Char -> Parser Char
escaped c = c <$ string ("\\" <> T.singleton c)
anyToken :: Parser Char
anyToken = satisfy $ const True
nonSpace :: Parser Char
nonSpace = satisfy $ not . isSpace