erebos-tester-0.3.6: src/Parser/Shell.hs

module Parser.Shell (
    ShellScript,
    shellScript,
) where

import Control.Applicative (liftA2)
import Control.Monad

import Data.Char
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL

import Text.Megaparsec
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer qualified as L

import Parser.Core
import Parser.Expr
import Script.Expr
import Script.Shell

parseTextArgument :: TestParser (Expr Text)
parseTextArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)) (Pure [])) $ some $ choice
    [ doubleQuotedString
    , singleQuotedString
    , standaloneEscapedChar
    , stringExpansion
    , unquotedString
    ]
  where
    specialChars = [ '"', '\'', '\\', '$', '#', '|', '>', '<', ';', '[', ']'{-, '{', '}' -}, '(', ')'{-, '*', '?', '~', '&', '!' -} ]

    stringSpecialChars = [ '"', '\\', '$' ]

    unquotedString :: TestParser (Expr Text)
    unquotedString = do
        Pure . TL.toStrict <$> takeWhile1P Nothing (\c -> not (isSpace c) && c `notElem` specialChars)

    doubleQuotedString :: TestParser (Expr Text)
    doubleQuotedString = do
        void $ char '"'
        let inner = choice
                [ char '"' >> return []
                , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` stringSpecialChars)) <*> inner
                , (:) <$> stringEscapedChar <*> inner
                , (:) <$> stringExpansion <*> inner
                ]
        App AnnNone (Pure T.concat) . foldr (liftA2 (:)) (Pure []) <$> inner

    singleQuotedString :: TestParser (Expr Text)
    singleQuotedString = do
        Pure . TL.toStrict <$> (char '\'' *> takeWhileP Nothing (/= '\'') <* char '\'')

    stringEscapedChar :: TestParser (Expr Text)
    stringEscapedChar = do
        void $ char '\\'
        fmap Pure $ choice $
            map (\c -> char c >> return (T.singleton c)) stringSpecialChars ++
            [ char 'n' >> return "\n"
            , char 'r' >> return "\r"
            , char 't' >> return "\t"
            , return "\\"
            ]

    standaloneEscapedChar :: TestParser (Expr Text)
    standaloneEscapedChar = do
        void $ char '\\'
        fmap T.singleton . Pure <$> printChar

parseRedirection :: TestParser (Expr ShellArgument)
parseRedirection = choice
    [ do
        rsymbol "<"
        fmap ShellRedirectStdin <$> parseTextArgument
    , do
        rsymbol ">"
        fmap (ShellRedirectStdout False) <$> parseTextArgument
    , do
        rsymbol ">>"
        fmap (ShellRedirectStdout True) <$> parseTextArgument
    , do
        rsymbol "2>"
        fmap (ShellRedirectStderr False) <$> parseTextArgument
    , do
        rsymbol "2>>"
        fmap (ShellRedirectStderr True) <$> parseTextArgument
    ]
  where
    rsymbol str = void $ try $ (string str <* notFollowedBy (satisfy $ (`elem` [ '<', '>', '|' ]))) <* sc

parseArgument :: TestParser (Expr ShellArgument)
parseArgument = choice
    [ parseRedirection
    , expressionExpansion "shell argument" <* sc
    , fmap ShellArgument <$> parseTextArgument
    ]

parseArguments :: TestParser (Expr ShellArguments)
parseArguments = do
    arglists <- many $ choice
        [ do
            off <- stateOffset <$> getParserState
            se <- someExpansion
            choice
                [ do
                    notFollowedBy space1
                    arg <- expansionTypeCheck off "shell argument" se
                    txt <- parseTextArgument
                    return $ joinArgument <$> arg <*> txt
                , do
                    expansionTypeCheck off "shell arguments" se <* sc
                ]
        , fmap (ShellArguments . (: [])) <$> parseArgument
        ]
    return $ fmap mconcat $ foldr (liftA2 (:)) (Pure []) $ arglists
  where
    joinArgument (ShellArgument x) y = ShellArguments [ ShellArgument (x <> y) ]
    joinArgument ax y = ShellArguments [ ax, ShellArgument y ]

parseCommand :: TestParser (Expr ShellCommand)
parseCommand = label "shell statement" $ do
    line <- getSourceLine
    choice
        [ do
            args <- expressionExpansion "shell command" <* sc
            args' <- parseArguments
            return $ commandFromArgLists line <$> args <*> args'
        , do
            command <- parseTextArgument
            args <- parseArguments
            return $ ShellCommand
                <$> command
                <*> args
                <*> pure line
        ]

  where
    commandFromArgLists line (ShellArguments (ShellArgument cmd : args)) (ShellArguments args') =
        ShellCommand cmd (ShellArguments (args ++ args')) line
    commandFromArgLists line (ShellArguments args) (ShellArguments args') =
        ShellCommand "" (ShellArguments (args ++ args')) line

parsePipeline :: Maybe (Expr ShellPipeline) -> TestParser (Expr ShellPipeline)
parsePipeline mbupper = do
    cmd <- parseCommand
    let pipeline =
            case mbupper of
                Nothing -> fmap (\ecmd -> ShellPipeline ecmd Nothing) cmd
                Just upper -> liftA2 (\ecmd eupper -> ShellPipeline ecmd (Just eupper)) cmd upper
    choice
        [ do
            psymbol "|"
            parsePipeline (Just pipeline)

        , do
            return pipeline
        ]
  where
    psymbol str = void $ try $ (string str <* notFollowedBy (satisfy $ (`elem` [ '<', '>', '|', '&' ]))) <* sc

parseStatement :: TestParser (Expr [ ShellStatement ])
parseStatement = do
    line <- getSourceLine
    fmap ((: []) . flip ShellStatement line) <$> parsePipeline Nothing

shellScript :: TestParser (Expr ShellScript)
shellScript = do
    indent <- L.indentLevel
    fmap ShellScript <$> blockOf indent parseStatement