1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
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 Pure $ choice $
map (\c -> char c >> return (T.singleton c)) specialChars ++
[ char ' ' >> return " "
]
parseRedirection :: TestParser (Expr ShellArgument)
parseRedirection = choice
[ do
osymbol "<"
fmap ShellRedirectStdin <$> parseTextArgument
, do
osymbol ">"
fmap (ShellRedirectStdout False) <$> parseTextArgument
, do
osymbol ">>"
fmap (ShellRedirectStdout True) <$> parseTextArgument
, do
osymbol "2>"
fmap (ShellRedirectStderr False) <$> parseTextArgument
, do
osymbol "2>>"
fmap (ShellRedirectStderr True) <$> parseTextArgument
]
parseArgument :: TestParser (Expr ShellArgument)
parseArgument = choice
[ parseRedirection
, fmap ShellArgument <$> parseTextArgument
]
parseArguments :: TestParser (Expr [ ShellArgument ])
parseArguments = foldr (liftA2 (:)) (Pure []) <$> many parseArgument
parseCommand :: TestParser (Expr ShellCommand)
parseCommand = label "shell statement" $ do
line <- getSourceLine
command <- parseTextArgument
args <- parseArguments
return $ ShellCommand
<$> command
<*> args
<*> pure 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
osymbol "|"
parsePipeline (Just pipeline)
, do
return pipeline
]
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
|