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
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
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
|