-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathMacroParser.hs
546 lines (495 loc) · 17.1 KB
/
MacroParser.hs
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
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
{-# LANGUAGE BangPatterns, ExistentialQuantification #-}
--import Prelude hiding (fold,foldr,foldl,foldl',foldr',foldl1,foldr1)
--module MacroParser2
import qualified Control.Monad
import qualified Control.Monad.State.Strict as State
import Control.Monad.State.Strict (StateT)
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Char8 (ByteString)
import qualified Data.Char
import qualified Data.Foldable
import qualified Data.Maybe
import Data.Maybe (Maybe)
import qualified Data.Sequence as Seq
import Data.Sequence (Seq, (|>), (<|), (><), ViewL(..), ViewR(..))
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Traversable
import qualified Data.Trie as Trie
import qualified Data.Trie.Internal as TrieInternal
import Data.Trie (Trie)
import qualified System.Environment
import Debug.Trace
type StringT = Seq Char
type BuiltinT = ParseState -> (ExpressionL, ParseState)
data MacroDef = User !ExpressionL
| Builtin !BuiltinT
instance Show MacroDef where
show (User x) = "(User (" ++ show x ++ "))"
show (Builtin _) = "(Builtin _)"
type MacroMap = Trie [Maybe MacroDef]
data ParseState = ParseState {
inputSeq :: !ExpressionL,
macroMap :: !MacroMap
} deriving (Show)
standardMacros = Trie.fromList [
(BS.pack "_cleanup", [Just $ Builtin cleanup]),
(BS.pack "pushDef" , [Just $ Builtin pushDefBuiltin]),
(BS.pack "popDef" , [Just $ Builtin popDefBuiltin]),
(BS.pack "quote" , [Just $ Builtin quoteBuiltin]),
(BS.pack "setDef" , [Just $ Builtin setDefBuiltin])]
standardParseState str = ParseState (Seq.singleton $ Sequence $ Seq.fromList str) standardMacros
--instance Show ParseState where
-- show (Par)
getInput :: (Monad m) => StateT ParseState m ExpressionL
getInput = do
state <- State.get
return $ inputSeq state
modifyInput :: (Monad m) => (ExpressionL->ExpressionL) -> StateT ParseState m ()
modifyInput f = State.modify $ \s -> s {inputSeq = f $ inputSeq s}
setInput :: (Monad m) => ExpressionL -> StateT ParseState m ()
setInput input = State.modify $ \s -> s {inputSeq = input}
getMacros :: (Monad m) => StateT ParseState m MacroMap
getMacros = do
state <- State.get
return $ macroMap state
modifyMacros :: (Monad m) => (MacroMap -> MacroMap) -> StateT ParseState m ()
modifyMacros f = State.modify $ \s -> s {macroMap = f $ macroMap s}
setMacros macros = State.modify $ \s -> s {macroMap = macros}
type ExpressionL = Seq Expression
data Expression = Null
| Sequence !StringT
| Special !Char
| Quote !ExpressionL
| Paren !ExpressionL
| Macro !Expression !(Seq ExpressionL)
deriving (Show)
toOutputString = stringFromStringT . toOutputStringExprL
toOutputStringExprL :: ExpressionL -> StringT
toOutputStringExprL aL = Data.Foldable.foldl' (><) Seq.empty $ fmap toOutputStringExpr aL
toOutputStringExpr :: Expression -> StringT
toOutputStringExpr (Sequence s) = s
toOutputStringExpr (Quote aL) = (<|) '[' $ toOutputStringExprL aL |> ']'
toOutputStringExpr (Paren aL) = (<|) '(' $ toOutputStringExprL aL |> ')'
toOutputStringExpr (Special c) = Seq.singleton c
toOutputStringExpr a = error $ "error: toOutputStringExpr " ++ show a
stringFromStringT :: StringT -> String
stringFromStringT = Data.Foldable.foldr (:) []
byteStringFromStringT = BS.pack . stringFromStringT
setDefs :: (Monad m) => ByteString -> [Maybe MacroDef] -> StateT ParseState m ()
setDefs name defs = modifyMacros $ Trie.insert name defs
getDefsMaybe :: (Monad m) => ByteString -> StateT ParseState m (Maybe [Maybe MacroDef])
getDefsMaybe name = do
macros <- getMacros
return $ Trie.lookup name macros
nothingToError :: Maybe a -> a
nothingToError (Just a) = a
nothingToError Nothing = error "nothingToError Nothing"
getDefs :: (Monad m) => ByteString -> StateT ParseState m [Maybe MacroDef]
getDefs name = getDefsMaybe name >>= return . nothingToError
getDefsDefault :: (Monad m) => ByteString -> StateT ParseState m [Maybe MacroDef]
getDefsDefault name = getDefsMaybe name >>= return . Data.Maybe.fromMaybe []
getDefMaybe :: (Monad m) => ByteString -> StateT ParseState m (Maybe MacroDef)
getDefMaybe name = do
defs <- getDefsDefault name
if null defs then
return Nothing
else if Data.Maybe.isNothing (head defs) then
return Nothing
else do
return . head $ defs
getDef :: (Monad m) => ByteString -> StateT ParseState m MacroDef
getDef name = getDefMaybe name >>= return . nothingToError
--expandMaybe :: a -> a -> Maybe b -> a
--expandMaybe x _ Nothing = x
--expandMaybe _ y (Just _) = y
setDef :: (Monad m) => ByteString -> Maybe MacroDef -> StateT ParseState m ()
--setDef name !def = do
-- modifyMacros $ Trie.adjust ((:) def . Data.Maybe.fromMaybe []) name
setDef name !def = do
defs <- getDefsDefault name
let defs' = if null defs then [def] else def : tail defs
setDefs name defs'
pushDef :: (Monad m) => ByteString -> Maybe MacroDef -> StateT ParseState m ()
pushDef name !def = do
defs <- getDefsDefault name
setDefs name (def:defs)
pushUserDef name def = pushDef name (fmap User def)
popDef :: (Monad m) => ByteString -> StateT ParseState m ()
popDef name = do
defs <- getDefsDefault name
if null defs then do
--don't
error $ "popDef " ++ show name ++ ": null defs"
else if null (tail defs) then do
modifyMacros $ Trie.delete name
else setDefs name (tail defs)
specialChars = Set.fromList [',',' ','\n','\t','\r','\f','\v']
isSpecialChar c = Set.member c specialChars
parseExpressionL = parseExpressionL' Seq.empty Seq.empty
parseExpressionL' :: (Monad m) => ExpressionL -> StringT -> StateT ParseState m ExpressionL
parseExpressionL' !resultL !resultStr = do
input <- getInput
if Seq.null input then
return $ if Seq.null resultStr then resultL else resultL |> Sequence resultStr
else do
let input1 :< inputL = Seq.viewl input
case input1 of
Sequence s -> do
if Seq.null s then do
setInput inputL
parseExpressionL' resultL resultStr
else do
let
x1:<xL = Seq.viewl s
input' = Sequence xL <| inputL
setInput input'
if x1 == ']' || x1 == ')' then do
return (if Seq.null resultStr then resultL else resultL |> Sequence resultStr)
else if x1 == '[' then do
let resultStrHelper = if Seq.null resultStr then Seq.empty else Seq.singleton $ Sequence resultStr
quot <- parseExpressionL' Seq.empty Seq.empty
parseExpressionL' (concatSequences $ Seq.fromList [resultL,resultStrHelper,Seq.singleton $ Quote quot]) Seq.empty
else if x1 == '(' then do
let resultStrHelper = if Seq.null resultStr then Seq.empty else Seq.singleton $ Sequence resultStr
paren <- parseExpressionL' Seq.empty Seq.empty
parseExpressionL' (concatSequences $ Seq.fromList [resultL,resultStrHelper,Seq.singleton $ Paren paren]) Seq.empty
else if isSpecialChar x1 then do
parseExpressionL' (if Seq.null resultStr then resultL |> Special x1 else resultL |> Sequence resultStr |> Special x1) Seq.empty
else do
parseExpressionL' resultL (resultStr |> x1)
--stringToParseTree s = State.evalState parseExpressionL (ParseState (Seq.singleton (Sequence (Seq.fromList s))) Trie.empty)
stringToParseTree s = State.evalState parseExpressionL (standardParseState s)
--bob = stringToParseTree "a[b]c"
processTree :: (Monad m) => ExpressionL -> StateT ParseState m ExpressionL
processTree tree = do
old <- getInput
setInput tree
result <- processInput
setInput old
return result
processInput :: (Monad m) => StateT ParseState m ExpressionL
processInput = do
input <- getInput
if Seq.null input then
return Seq.empty
else do
let (i1:<iL) = Seq.viewl input
setInput iL
case i1 of
-- Special ']' -> return Seq.empty
Special c -> do
tail <- processInput
return $ (Special c) <| tail
Quote e -> do
tail <- processInput
return $ e >< tail
Paren e -> do
e' <- processTree e
tail <- processInput
return $ Paren e' <| tail
Sequence s -> do
if Seq.null s then do
setInput iL
processInput
else do
let s1:<sL = Seq.viewl s
setInput input
b <- parseMacro
if b then do
processInput
else do
setInput $ Sequence sL <| iL
tail <- processInput
if Seq.null tail then
return $ Seq.singleton $ Sequence $ Seq.singleton s1
else do
let t1:<tL = Seq.viewl tail
case t1 of
Sequence seq2 -> return $ Sequence (s1<|seq2) <| tL
_ -> return $ Sequence (Seq.singleton s1) <| tail
Macro name args -> do
callMacro name args
callMacro (Sequence name) args = do
definition <- getDef $ byteStringFromStringT name
-- let expansion = Data.Maybe.fromJust $ Trie.lookup (BS.pack $ Data.Foldable.foldr (:) [] name) macroTable --TODO: builtin vs custom
cleanup <- setupArgs name args
input <- getInput
case definition of
User expansion -> do
expansion' <- processTree expansion
setInput (cleanup >< input)
tail <- processInput
return $ expansion' >< tail
-- setInput $ expansion >< cleanup >< input
-- processInput
Builtin operation -> do
--do NOT schedule cleanup, because otherwise infinite loop with cleanup after cleanup
-- let input2 = cleanup >< input
-- setInput input2
state <- State.get
let (result,state2) = operation state
State.put state2
input2 <- getInput
setInput $ result >< input2
processInput
setupArgs :: (Monad m) => StringT -> Seq ExpressionL -> StateT ParseState m ExpressionL
setupArgs name args = do
oldArgCount <- getArgCount
let argCount = Seq.length args
pushUserDef (BS.pack "$@") . Just . intercalate (Special ',') $ args
pushUserDef (BS.pack "$#") . Just . Seq.singleton . Sequence . Seq.fromList . show $ argCount
pushUserDef (BS.pack "$0") . Just . Seq.singleton . Sequence $ name
pushArgs (1::Int) args
maskArgs (argCount+1) oldArgCount
return $ Seq.fromList [Sequence $ Seq.fromList "_cleanup", Special ' ']
where
intercalate separator args
| Seq.null args = Seq.empty
| otherwise = helper Seq.empty args
where
helper !result args = let arg1:<argL = Seq.viewl args in
if Seq.length args == 1 then
result |> Quote arg1
else helper (flip (|>) separator $ result >< arg1) argL
pushArgs !n args
| Seq.null args = return ()
| otherwise = do
let arg1:<argL = Seq.viewl args
pushUserDef (BS.pack $ "$" ++ show n) (Just arg1)
pushArgs (n+1) argL
maskArgs arg max = maskArgs' arg where
_ = (arg,max) :: (Int,Int)
maskArgs' arg =
if arg <= max then do
pushUserDef (BS.pack $ "$" ++ show arg) Nothing
maskArgs' (arg+1)
else don't
don't :: Monad m => m ()
don't = return ()
parseMacro :: (Monad m) => StateT ParseState m Bool
parseMacro = do
macroName <- parseLongestMacro
if Seq.null macroName then do
return False
else do
arguments <- parseMacroArguments
input <- getInput
-- arguments' <- Data.Traversable.mapM processTree arguments
setInput $ Macro (Sequence macroName) arguments <| input
return True
parseLongestMacro :: (Monad m) => StateT ParseState m StringT
parseLongestMacro = do
macros <- getMacros
input <- getInput
if Seq.null input then
return Seq.empty
else do
let i1:<iL = Seq.viewl input
case i1 of
Sequence _ -> do
result <- helper Seq.empty macros
if Seq.null result then do
setInput input
else don't
return result
_ -> return Seq.empty
where
helper !result !macros = do
input <- getInput
if Seq.null input then
return result
else do
if Trie.null macros then
return Seq.empty
else do
let (Sequence s):<iL = Seq.viewl input
if Trie.member BS.empty macros then do
longer <- helper result (Trie.delete BS.empty macros)
if Seq.null longer then do
setInput input
return result
else return longer
else if Seq.null s then
return Seq.empty
else do
let s1:<sL = Seq.viewl s
setInput $ Sequence sL <| iL
helper (result|>s1) (trieReducer (BS.singleton s1) macros)
trieReducer :: ByteString -> Trie a -> Trie a
trieReducer prefix names = TrieInternal.lookupBy_ (\a tr -> if Data.Maybe.isJust a then Trie.insert BS.empty (Data.Maybe.fromJust a) tr else tr) Trie.empty id prefix names
parseMacroArguments :: (Monad m) => StateT ParseState m (Seq ExpressionL)
parseMacroArguments = do
input <- getInput
if Seq.null input then
return Seq.empty
else do
let i1:<iL = Seq.viewl input
case i1 of
Paren eL -> do
eL' <- processTree eL
setInput eL'
result <- parseArgs Seq.empty
setInput iL
return result
Sequence s -> do
if Seq.null s then do
setInput iL
parseMacroArguments
else return Seq.empty
_ -> return Seq.empty
parseArgs !result = do
input <- getInput
if Seq.null input then
return result
else do
let i1:<iL = Seq.viewl input
case i1 of
Special c ->
if Data.Char.isSpace c then do
setInput iL
parseArgs result
else do
arg <- parseArg Seq.empty
arg' <- processTree arg
parseArgs $ result |> arg'
_ -> do
arg <- parseArg Seq.empty
arg' <- processTree arg
parseArgs $ result |> arg'
parseArg !result = do
input <- getInput
if Seq.null input then
return result
else do
let i1:<iL = Seq.viewl input
setInput iL
case i1 of
Special c ->
if c == ',' then do
return result
else parseArg $ result |> i1
_ -> parseArg $ result |> i1
concatSequences :: Seq (Seq a) -> Seq a
concatSequences = Data.Foldable.foldl' (><) Seq.empty
builtinHelper x = do
state <- State.get
let (result,state') = x state
State.put state'
return result
getArgCount :: (Monad m) => StateT ParseState m Int
getArgCount = do
argCount1 <- getDefMaybe (BS.pack "$#")
let
argCount2 = do
arg <- argCount1
arg2 <- case arg of
User a -> return a
_ -> Nothing
let arg3 = toOutputString arg2
return (read arg3)
argCount = Data.Maybe.fromMaybe (-1) argCount2
-- argCount = Data.Maybe.fromMaybe (-1) argCount2
-- Debug.Trace.traceShow argCount $ return argCount
return argCount
--TODO: could be slightly more efficient by walking down the Trie to the place where all the $ things are
cleanup :: ParseState -> (ExpressionL,ParseState)
cleanup state0 = State.runState helper state0 where
helper = {-Debug.Trace.trace "\n\n\n\n" $ Debug.Trace.traceShow state0 $-} do
-- argCount1 <- getDefMaybe
--pop the arguments passed to the cleanup function itself
popDef (BS.pack "$@")
popDef (BS.pack "$#")
popDef (BS.pack "$0")
argCount <- getArgCount
-- argCount' <- getArgCount
-- argCount <- Debug.Trace.trace ("\ncleanup: argCount="++show argCount'++"\n") $ return argCount'
popDef (BS.pack "$@")
popDef (BS.pack "$#")
popDef (BS.pack "$0")
oldArgCount <- getArgCount
-- oldArgCount' <- getArgCount
-- oldArgCount <- Debug.Trace.trace ("\ncleanup: oldArgCount="++show oldArgCount'++"\n") $ return oldArgCount'
popArgs 1 (argCount::Int)
popArgs 1 (argCount::Int)
popArgs (1+argCount) oldArgCount
input <- getInput
if Seq.null input then
error "null input in cleanup"
else do
let i1:<iL = Seq.viewl input
case i1 of
Special ' ' -> do
setInput iL
_ -> error "Did not find space after cleanup!"
state <- State.get
-- Debug.Trace.traceShow state $ return Seq.empty
return Seq.empty
popArgs n max =
if n <= max then do
popDef . BS.pack . (:) '$' . show $ n
popArgs (n+1) max
else return ()
where _ = n :: Int
cleanupHelper = do
input <- getInput
setInput (Special ' ' <| input)
n <- getArgCount
maskArgs (1::Int) (n::Int)
pushUserDef (BS.pack "$@") Nothing
pushUserDef (BS.pack "$#") Nothing
pushUserDef (BS.pack "$0") Nothing
builtinHelper cleanup
where
maskArgs b max = helper b where
helper a = if a > max then don't else do
pushUserDef (BS.pack . (:) '$' . show $ a) Nothing
helper (a+1)
pushDefBuiltin :: BuiltinT
pushDefBuiltin state = State.runState helper state where
helper = {-trace "\n\n\n" $ traceShow state $-} do
User arg1 <- getDef (BS.pack "$1")
User arg2 <- getDef (BS.pack "$2")
pushDef (BS.pack $ toOutputString arg1) (Just $ User $ arg2)
cleanupHelper
return Seq.empty
popDefBuiltin :: BuiltinT
popDefBuiltin state = State.runState helper state where
helper = do
User arg1 <- getDef (BS.pack "$1")
-- let (Sequence arg1_2):<_ = Seq.viewl arg1_1
popDef (BS.pack $ toOutputString arg1)
cleanupHelper
return Seq.empty
setDefBuiltin :: BuiltinT
setDefBuiltin state = State.runState helper state where
helper = do
User arg1 <- getDef (BS.pack "$1")
User arg2 <- getDef (BS.pack "$2")
setDef (BS.pack $ toOutputString arg1) (Just $ User $ arg2)
cleanupHelper
return Seq.empty
quoteBuiltin :: BuiltinT
quoteBuiltin state = State.runState helper state where
helper = do
User arg1 <- getDef (BS.pack "$1")
cleanupHelper
return . Seq.singleton . Quote . Seq.singleton . Quote $ arg1
test str = State.runState helper (standardParseState str) where
helper = do
tree <- parseExpressionL
processTree tree
main = do
args <- System.Environment.getArgs
let
str = unwords args
(result,state) = test str
putStrLn $ ("input = " ++ show str)
putStrLn $ ("result = \"" ++ (toOutputString $ result) ++ "\"")
putStrLn $ ("state = \"" ++ show state ++ "\"")
--example1 = "a" ++ "pushDef([[f],[g([[a]],quote($@))]])" ++ "f([[b],[c]])"
example1 = "pushDef([[f],[g([a],$@)]])f([[b],[c]])"
example2 = "pushDef(a,b)a"
example3 = "pushDef(a,b)a(x,y)"
example4 = "pushDef([[a],[b]])quote([a])"
runMain str = System.Environment.withArgs [str] main