-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathxdc.hs
More file actions
2132 lines (1983 loc) · 144 KB
/
xdc.hs
File metadata and controls
2132 lines (1983 loc) · 144 KB
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
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
--Jesse A. Jones
--Version: Alpha 1.1.1
--Compiler for EcksDee
import Data.List
import Data.Char
import Data.Maybe
import Debug.Trace
import Text.Read (readMaybe)
import System.IO
import System.Environment
import qualified Data.Map.Strict as M
import Control.DeepSeq
import Control.Exception
import Data.Typeable
import System.IO.Error (tryIOError)
import System.Exit (ExitCode(..))
import System.Process (system)
import Data.List (isSuffixOf)
data Value =
BigInteger Integer
| Integer Int
| Float Float
| Double Double
| String {chrs :: [Char], len :: Int}
| Char Char
| Boolean Bool
| List { items :: M.Map Int Value, len :: Int}
| Object { fields :: M.Map String Value }
| Box Int
deriving (Eq, Show, Ord)
-- or it can be an operation, which has a string name.
-- the program "2 2 +" would have tokens [ I 2, I 2, Op "+" ]
data Token =
Val Value
| Word String
deriving ( Eq, Show )
-- Deriving "Eq" means that we can use == and /= between tokens. E.g., I 2 == I 2
-- Deriving "Show" means that we can use "print" on tokens.
-- An abstract syntax tree
data AstNode =
-- a single token
Terminal Token
-- an if node. contains two branches: one for true and one for false.
| If { ifTrue :: AstNode, ifFalse :: AstNode }
-- a while node. contains only a child node for the body of the loop.
| While AstNode
-- a list of nodes. Represents a sequence of instructions like "1 1 + 2 *"
| Expression [ AstNode ]
| Function {funcCmd :: AstNode, funcName :: AstNode, funcBod :: AstNode}
| Variable {varName :: AstNode, varCmd :: AstNode}
| LocVar {name :: AstNode, cmd :: AstNode}
| AttErr {attempt :: AstNode, onError :: AstNode}
| TempStackChange AstNode
| BoxOp AstNode
deriving ( Show )
data Heap = Heap {
freeList :: M.Map Int (),
h :: M.Map Int Value,
heapSize :: Int
}
-- This is the state of the interpreter.
-- Currently it stores the stack, which is where all of the data lives.
data EDState = EDState {
stack :: [Value],
fns :: M.Map String AstNode,
vars :: M.Map String Value,
frames :: [M.Map String Value],
heap :: Heap
}
data GeneralException = GeneralException String deriving (Show, Typeable)
instance Exception GeneralException
--Used in throwing error.
throwError :: String -> EDState -> IO EDState
throwError msg = throw $ GeneralException msg
--Parses tokens into an abstract syntax tree.
parseExpression' :: [AstNode] -> [Token] -> [String] -> ( [AstNode], [Token], Maybe Token )
-- if there are no more tokens, we need to check if we have terminators.
-- if we were expecting a terminator and there isn't one, that's an error.
parseExpression' alreadyParsed [] terminators =
-- this is the base case: nothing to parse
if null terminators then ( alreadyParsed, [], Nothing )
-- error case
else error ( "Ended expression without finding one of: " ++ intercalate ", " terminators )
-- if tokens remain, keep parsing
parseExpression' alreadyParsed ( token:tokens ) terminators
-- found a terminator: stop parsing and return.
| token `elem` map Word terminators = ( alreadyParsed, tokens, Just token )
-- found an if-statement: remove the "if" token, parse the true and false branches, and
-- then parse whatever is after the if-statement.
| token == Word "if" =
let ( trueBranch, falseBranch, remTokens ) = parseIf tokens
newParsed = If{ifTrue = trueBranch, ifFalse = falseBranch} : alreadyParsed
in parseExpression' newParsed remTokens terminators
-- found a while-statement: remove the "while", parse the body, then parse whatever is after
| token == Word "while" =
let (bod, remTokens) = parseWhile tokens
newParsed = (While bod) : alreadyParsed
in parseExpression' newParsed remTokens terminators
--Parse function definition.
| token == Word "func" =
let (cmd, name, bod, remTokens) = parseFuncOp tokens
newParsed = Function{funcCmd = cmd, funcName = name, funcBod = bod} : alreadyParsed
in parseExpression' newParsed remTokens terminators
--Parse basic variable case.
| token == Word "var" =
let (varAct, variableName, remTokens) = parseVarAction tokens
newParsed = Variable{varName = variableName, varCmd = varAct} : alreadyParsed
in parseExpression' newParsed remTokens terminators
--Parse local variable.
| token == Word "loc" =
let (varAct, variableName, remTokens) = parseVarAction tokens
newParsed = LocVar{name = variableName, cmd = varAct} : alreadyParsed
in parseExpression' newParsed remTokens terminators
--Parse attErr block.
| token == Word "attempt" =
let (attemptBranch, errorBranch, remTokens) = parseAttErr tokens
in parseExpression' (AttErr{attempt = attemptBranch, onError = errorBranch} : alreadyParsed) remTokens terminators
--Parse tempStackChange block
| token == Word "tempStackChange" =
let (runBlock, remTokens) = parseTempStackChange tokens
in parseExpression' ((TempStackChange runBlock) : alreadyParsed) remTokens terminators
| token == Word "box" =
let (boxWords, remTokens, term) = parseExpression' [] tokens [";"]
in parseExpression' ((BoxOp $ head $ reverse boxWords) : alreadyParsed) remTokens terminators
-- no special word found. We are parsing a list of operations. Keep doing this until
-- there aren't any.
| otherwise = parseExpression' ((Terminal token) : alreadyParsed) (tokens) (terminators)
-- takes the result of parseExpression' and wraps it in an Expression constructor
parseExpression :: [Token] -> AstNode
parseExpression tokens =
let (nodes, toks, potTok) = parseExpression' [] tokens []
in Expression(reverse nodes)
--Custom trace function used during debugging. Made by Grant.
traceThing :: (Show a) => a -> a
traceThing x = traceShow x x
parseTempStackChange :: [Token] -> (AstNode, [Token])
parseTempStackChange [] = error "tempStackChange missing closing semicolon!"
parseTempStackChange tokens =
let (runBlock, remTokens, terminator) = parseExpression' [] tokens [";"]
in (Expression $ reverse runBlock, remTokens)
--Parses an attErr code block into its appropriate expression.
parseAttErr :: [Token] -> (AstNode, AstNode, [Token])
parseAttErr tokens =
let (attBranch, remainingTokens, terminator ) = parseExpression' [] tokens [ "onError", ";" ]
(errBranch, remTokens) = if terminator == (Just $ Word "onError")
then parseErrorBranch remainingTokens
else error "attempt onError Error:\n Branch onError branch missing.\nUSAGE: attempt CODE_TO_ATTEMPT onError CODE_TO_HANDLE_ERROR ;"
in (Expression $ reverse attBranch , errBranch, remTokens)
--Parses the onError branch of attErr.
parseErrorBranch :: [Token] -> (AstNode, [Token])
parseErrorBranch tokens =
let (errorHandleCode, remTokens, terminator) = parseExpression' [] tokens [";"]
in (Expression $ reverse errorHandleCode, remTokens)
parseVarAction :: [Token] -> (AstNode, AstNode, [Token])
parseVarAction (token:tokens) =
let (varInfo, remTokens, terminator) = parseExpression' [] tokens [";"]
revVarInfo = reverse varInfo
varAction = Terminal token
varName = if not $ null (tail revVarInfo)
then error "Malformed variable command" else head revVarInfo
in (varAction, varName, remTokens)
--Parses a function definition.
parseFuncOp :: [Token] -> (AstNode, AstNode, AstNode, [Token])
parseFuncOp (command:name:tokens) =
let (funcBody, remTokens, terminator) = parseExpression' [] tokens [";"]
funcCommand = Terminal command
funcName = Terminal name
in (funcCommand, funcName, Expression $ reverse funcBody, remTokens)
-- we just saw an "if". now we have to build an "If" AstNode.
-- returns the two branches and the remaining tokens.
-- ( ifTrue, ifFalse, remainingTokens ).
parseIf :: [Token] -> ( AstNode, AstNode, [Token] )
parseIf tokens =
let ( trueBranch, remainingTokens, terminator ) = parseExpression' [] tokens [ "else", ";" ]
(falseBranch, remTokens) = if terminator == (Just $ Word "else")
then parseElse remainingTokens
else (Expression([]), remainingTokens)
in (Expression $ reverse trueBranch, falseBranch, remTokens)
-- we just saw an "else". now finish the ifFalse part of the If node. This one only needs to
-- return the "false" branch of the if statement, which is why there is only one [AstNode] in
-- the return value.
parseElse :: [Token] -> ( AstNode, [Token] )
parseElse tokens =
let (ifFalse, remTokens, terminator) = parseExpression' [] tokens [";"]
in (Expression $ reverse ifFalse, remTokens)
-- parsing a while loop is similar to parsing an if statement.
parseWhile :: [Token] -> ( AstNode, [Token] )
-- if we reach the end of our tokens without closing the loop, that's an error
parseWhile [] = error "while without closing semicolon."
-- otherwise, parse the loop body until reaching the ";"
parseWhile tokens = let (loopBod, remTokens, terminator) = parseExpression' [] tokens [";"]
in (Expression $ reverse loopBod, (remTokens))
--Makes new interpretor state with default values.
fsNew :: IO EDState
fsNew = return EDState { stack = [], fns = M.empty, vars = M.empty, frames = [M.empty], heap = Heap{freeList = M.empty, h = M.empty, heapSize = 0}}
--Counts the number of decimal points in a string.
decCount :: String -> Int
decCount "" = 0
decCount (x:xs) = if x == '.' then 1 + decCount xs else decCount xs
isNum' :: String -> Bool -> Bool
isNum' "" isNum = isNum
isNum' (x:xs) isNum =
let nums = "0123456789"
in if not (x `elem` nums || x == '.' || x == 'e' || x == '-')
then isNum' xs False
else isNum' xs isNum
--Determines if a string is a valid number.
isNum :: String -> Int
isNum "" = -1
isNum numStr =
let containsValidChars = isNum' numStr True
decimalPoints = decCount numStr
minusSigns = length $ filter (=='-') numStr
exponentCount = length $ filter (=='e') numStr
in if containsValidChars
then case (decimalPoints, minusSigns, exponentCount) of
(0, 0, 0) -> 0
(1, 0, 0) -> 1
(1, 0, 1) -> 1
(1, 1, 1) -> 1
_ -> -1
else -1
-- Used to turn the strings into values and other tokens.
lexToken :: String -> Token
lexToken t
| t == "true" || t == "True" = Val $ Boolean True --Boolean cases.
| t == "false" || t == "False" = Val $ Boolean False
| t == "[]" = Val $ List {items = M.empty, len = 0} --Empty list case.
| t == "{}" = Val $ Object {fields = M.empty} --Empty object case.
| (head t) == '"' && (last t) == '"' =
let str = read t :: String
in Val $ String { chrs = str, len = length str } --String case
| isValidChar t = Val $ Char (read t :: Char) --Char case.
| (last t == 'b') && ((isNum (if head t == '-' then tail $ init t else init t)) == 0) = Val $ BigInteger (read (init t) :: Integer) --BigInteger case
| (last t == 'd') && ((isNum (if head t == '-' then tail $ init t else init t)) == 1) = Val $ Double (read (init t) :: Double) -- Double case
| (isNum (if head t == '-' then tail t else t)) == 0 = Val $ Integer (read t :: Int) --Int Case
| (isNum (if head t == '-' then tail t else t)) == 1 = Val $ Float (read t :: Float) --Float case
| otherwise = Word t
--Determines if a string can be casted to a char.
isValidChar :: String -> Bool
isValidChar str =
let parseRes = readMaybe str :: Maybe Char
isValid = case parseRes of
Just _ -> True
Nothing -> False
in isValid
-- Takes a whole program and turns it into a list of tokens. Calls "lexToken"
tokenize :: String -> [Token]
tokenize code = map lexToken $ tokenize' code
--This code makes creating a list of strings
-- from the code easier in the above function call.
tokenize' :: String -> [String]
tokenize' "" = []
tokenize' str = tokenize'' str "" [] False False
--This function does the heavy lifting of spitting up the code into tokens.
tokenize'' :: String -> String -> [String] -> Bool -> Bool -> [String]
tokenize'' "" _ _ False True = error "Parse Error: Code ended without array being closed." --Error case if array isn't closed.
tokenize'' "" _ _ True False = error "Parse Error: Code ended without string being closed." --Error case for non closed string.
tokenize'' "" currStr strs False False = strs ++ (if null currStr then [] else [currStr]) --Parsing is complete case.
tokenize'' (('\''):c:('\''):xs) currStr strs False False = tokenize'' xs currStr (strs ++ [ "\'" ++ [c] ++ "\'" ] ) False False --Character case.
tokenize'' (('\"'):xs) currStr strs False False = tokenize'' xs (currStr ++ ['\"']) strs True False --String enter case.
tokenize'' (('\"'):xs) currStr strs True False = tokenize'' xs [] (strs ++ [currStr ++ ['\"']]) False False --Exiting string case.
tokenize'' (('\\'):('\"'):xs) currStr strs True False = tokenize'' xs (currStr ++ "\\\"") (strs) True False --In string case for quotes in quotes.
--tokenize'' (('\\'):('{'):xs) currStr strs True False = tokenize'' xs (currStr ++ ['\{']) strs True False --In string case for left array bracket in a string. FIX LATER MAYBE???????
--tokenize'' (('\\'):('}'):xs) currStr strs True False = tokenize'' xs (currStr ++ ['\}']) strs True False --In string case for right array bracket in a string.
tokenize'' (x:xs) currStr strs True False = tokenize'' xs (currStr ++ [x]) strs True False --In string case
--ADD ARRAY TOKENIZATION LATER!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--General parsing case.
tokenize'' (x:xs) currStr strs False False = if not $ isSpace x
then tokenize'' xs (currStr ++ [x]) strs False False
else tokenize'' xs [] (strs ++ (if null currStr then [] else [currStr])) False False
-- removes comments from a token stream. comments are between /' and '/
-- arguments:
-- * the first bool tells us whether we are in a comment or not. starts false.
-- * the first token list is the tokens that are not inside of comments. starts empty.
-- * the last list are the remaining tokens
removeComments :: Bool -> [Token] -> [Token] -> [Token]
-- If the first argument is 'true', we're inside a comment. but the [] means no more tokens.
removeComments True _ [] = error "ended comment while it's still open. need closing '/ ."
-- If we finish all the tokens and are not in a comment, there's nothing else to do
-- except reversing the nonComments tokens (because we've been appending to the front)
removeComments False nonComments [] = reverse nonComments
-- If we're in a comment and we find '/, we close the comment and continue
removeComments True nonComments ( Word ("'/"):xs ) = removeComments False nonComments xs
-- If we're in a comment, ignore whatever token comes next
removeComments True nonComments ( _:xs ) = removeComments True nonComments xs
-- If we're not in a comment and we find /', start the comment
removeComments False nonComments ( Word ("/'"):xs ) = removeComments True nonComments xs
-- If we're not in a comment, add the token to the nonComment tokens
removeComments False nonComments ( x:xs ) = removeComments False (x:nonComments) xs
nFourSpaces' :: Int -> String -> String
nFourSpaces' 0 acc = acc
nFourSpaces' n acc =
nFourSpaces' (n - 1) (' ':' ':' ':' ':acc)
nFourSpaces :: Int -> String
nFourSpaces count = nFourSpaces' count ""
--Uses pattern matching to find type of given value.
doQueryType' :: Value -> Value
doQueryType' (BigInteger _) = String{chrs = "BigInteger", len = length "BigInteger"}
doQueryType' (Integer _) = String{chrs = "Integer", len = length "Integer"}
doQueryType' (Float _) = String{chrs = "Float", len = length "Float"}
doQueryType' (Double _) = String{chrs = "Double", len = length "Double"}
doQueryType' String{chrs = _, len = _} = String{chrs = "String", len = length "String"}
doQueryType' (Char _) = String{chrs = "Char", len = length "Char"}
doQueryType' (Boolean _) = String{chrs = "Boolean", len = length "Boolean"}
doQueryType' (List {items = _, len = _}) = String{chrs = "List", len = length "List"}
doQueryType' (Object {fields = _}) = String{chrs = "Object", len = length "Object"}
doQueryType' (Box _) = String{chrs = "Box", len = length "Box"}
makeLine :: Int -> [String] -> String
makeLine indent strs = intercalate "" ((nFourSpaces indent):strs)
--This function is seperate from the main blocks because it'll be called twice,
-- since both "push" and "p" are valid to push stuff to lists.
makeListPushCode :: Int -> Int -> ([String], Int)
makeListPushCode indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "', secondToTop, top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just (List{items = is, len = l}), Just v) -> return $ push ", stateStr, "' (List{items = M.insert l v is, len = l + 1})"],
makeLine (indent + 1) ["(Just (String{chrs = cs, len = l}), Just (Char c)) -> return $ push ", stateStr, "' (String{chrs = cs ++ [c], len = l + 1})"],
makeLine (indent + 1) ["(Just (String{chrs = cs, len = l}), Just v) -> let vType = chrs $ doQueryType' v in throwError (\"Operator (push) error.\
\ Push operator needs a List/String and a Value/Char to be pushed. Attempted types: String and \" ++ vType) ", stateStr],
makeLine (indent + 1) ["(Just v1, Just v2) -> let (v1Type, v2Type) = findTypeStrsForError v1 v2 in throwError (\"Operator (push) error.\
\ Push operator needs a List/String and a Value/Char to be pushed. Attempted types: \" ++ v1Type ++ \" and \" ++ v2Type) ", stateStr],
makeLine (indent + 1) ["(Nothing, Just v2) -> throwError \"Operator (push) error. Two operands required for push; only one provided!\" ", stateStr],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError \"Operator (push) error. Two operands required for push; none provided!\" ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
makeListPopCode :: Int -> Int -> ([String], Int)
makeListPopCode indent stateCount =
let stateStr = "state" ++ (show stateCount)
stateStr' = stateStr ++ "'"
codeLines =
[
makeLine indent ["let (", stateStr', ", top) = pop ", stateStr],
makeLine indent ["newState <- case top of"],
makeLine (indent + 1) ["Just (List{items = _, len = 0}) -> return ", stateStr],
makeLine (indent + 1) ["Just (List{items = is, len = l}) -> \
\let popped = fromJust (M.lookup (l - 1) is) ; is' = M.delete (l - 1) is \
\in return $ push (push ", stateStr', "(List{items = is', len = l - 1})) (popped)"],
makeLine (indent + 1) ["Just (String{chrs = \"\", len = 0}) -> return ", stateStr],
makeLine (indent + 1) ["Just (String{chrs = cs, len = l}) -> let newStr = String{chrs = init cs, len = l - 1} ; popped = Char $ last cs \
\in return $ push (push ", stateStr', " (newStr)) popped"],
makeLine (indent + 1) ["Just v -> let vType = chrs $ doQueryType' v in throwError (\"Operator (pop) error.\
\ Pop operator needs a List/String to pop items on top of stack. Attempted type: \" ++ vType) ", stateStr'],
makeLine (indent + 1) ["Nothing -> throwError \"Operator (pop). error. Pop operator needs one operand; none provided!\" ", stateStr'],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
createListFrontPushCode :: Int -> Int -> ([String], Int)
createListFrontPushCode indent stateCount =
let stateStr = "state" ++ (show stateCount)
stateStr' = stateStr ++ "'"
codeLines =
[
makeLine indent ["let (", stateStr, "', secondToTop, top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just (List{items = is, len = l}), Just v) -> ",
"let updateList = (\\List{items = is, len = l} index insVal -> \
\if index < l \
\then let old = fromJust $ M.lookup index is ; \
\is' = M.insert index insVal is \
\in updateList List{items = is', len = l} (index + 1) old " ,
"else let is' = M.insert index insVal is in List{items = is', len = l + 1}",
" ) ; ",
"newList = updateList List{items = is, len = l} 0 v ",
"in return $ push ", stateStr', " newList"
],
makeLine (indent + 1) ["(Just (String{chrs = cs, len = l}), Just (Char c)) -> return $ push ", stateStr, "' (String{chrs = (c:cs), len = l + 1})"],
makeLine (indent + 1) ["(Just (String{chrs = cs, len = l}), Just v) -> let vType = chrs $ doQueryType' v in throwError (\"Operator (fpush) error.\
\ Operator fpush needs a List/String and a Value/Char to be pushed to front. Attempted types: String and \" ++ vType) ", stateStr],
makeLine (indent + 1) ["(Just v1, Just v2) -> let (v1Type, v2Type) = findTypeStrsForError v1 v2 in throwError (\"Operator (fpush) error.\
\ Operator fpush needs a List/String and a Value/Char to be pushed to front. Attempted types: \" ++ v1Type ++ \" and \" ++ v2Type) ", stateStr],
makeLine (indent + 1) ["(Nothing, Just v2) -> throwError \"Operator (fpush) error. Two operands required for fpush; only one provided!\" ", stateStr],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError \"Operator (fpush) error. Two operands required for fpush; none provided!\" ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateLengthCode :: Int -> Int -> ([String], Int)
generateLengthCode indent stateCount =
let stateStr = "state" ++ (show stateCount)
stateStr' = stateStr ++ "'"
codeLines =
[
makeLine indent ["let (", stateStr', ", top) = pop ", stateStr],
makeLine indent ["newState <- case top of"],
makeLine (indent + 1) ["Just List{items = _, len = l} -> return $ push ", stateStr, " (Integer l)"],
makeLine (indent + 1) ["Just String{chrs = _, len = l} -> return $ push ", stateStr, " (Integer l)"],
makeLine (indent + 1) ["Just v -> let vType = chrs $ doQueryType' v in \
\throwError (\"Operator (length) error. List/String type is needed for length operator to work. Attempted type: \" ++ vType) ", stateStr],
makeLine (indent + 1) ["Nothing -> throwError (\"Operator (length) error. Operand needed for length; none provided!\") ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
createListFrontPopCode :: Int -> Int -> ([String], Int)
createListFrontPopCode indent stateCount =
let stateStr = "state" ++ (show stateCount)
stateStr' = stateStr ++ "'"
codeLines =
[
makeLine indent ["let (", stateStr', ", top) = pop ", stateStr],
makeLine indent ["newState <- case top of"],
makeLine (indent + 1) ["Just (List{items = _, len = 0}) -> return ", stateStr],
makeLine (indent + 1) ["Just (List{items = is, len = l}) -> ",
"let popped = fromJust $ M.lookup 0 is ; ",
"updateList = (\\List{items = as, len = al} List{items = bs, len = bl} index -> ",
"if index < al then let ins = fromJust $ M.lookup index as ; bs' = M.insert (index - 1) ins bs ",
"in updateList List{items = as, len = al} List{items = bs', len = bl + 1} (index + 1)",
" else List{items = bs, len = bl}",
") ; ",
"newLs = updateList List{items = is, len = l} List{items = M.empty, len = 0} 1 ; ",
"in return $ push (push ", stateStr', " newLs) popped"
],
makeLine (indent + 1) ["Just (String{chrs = \"\", len = 0}) -> return ", stateStr],
makeLine (indent + 1) ["Just (String{chrs = cs, len = l}) -> let popped = Char $ head cs ; newStr = String{chrs = tail cs, len = l - 1} in \
\return $ push (push ", stateStr', " newStr) popped"],
makeLine (indent + 1) ["Just v -> let vType = chrs $ doQueryType' v in throwError (\"Operator (fpop) error. \
\Popping from front requires a List/String to pop from. Attempted type: \" ++ vType) ", stateStr'],
makeLine (indent + 1) ["Nothing -> throwError \"Operator (fpop) error. Needs one operand to work; none provided!\" ", stateStr'],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode :: String -> Int -> Int -> ([String], Int)
generateOpCode "+" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "'", ", ", "secondToTop, ", "top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just v1, Just v2) -> "],
makeLine (indent + 2) ["case (addVals v1 v2) of"],
makeLine (indent + 3) ["Left v -> return $ push ", stateStr, "' (v)"],
makeLine (indent + 3) ["Right err -> throwError err ", stateStr],
makeLine (indent + 1) ["(Nothing, Just v2) -> ", "throwError \"Operator (+) error. Addition requires two operands; only one provided!\" ", stateStr],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError \"Operator (+) error. Addition requires two operands; none provided!\" ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "-" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "'", ", ", "secondToTop, ", "top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just v1, Just v2) -> "],
makeLine (indent + 2) ["case (subVals v2 v1) of"],
makeLine (indent + 3) ["Left v -> return $ push ", stateStr, "' (v)"],
makeLine (indent + 3) ["Right err -> throwError err ", stateStr],
makeLine (indent + 1) ["(Nothing, Just v2) -> ", "throwError \"Operator (-) error. Subtraction requires two operands; only one provided!\" ", stateStr],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError \"Operator (-) error. Subtraction requires two operands; none provided!\" ", stateStr],
makeLine (indent) ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "*" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "'", ", ", "secondToTop, ", "top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just v1, Just v2) -> "],
makeLine (indent + 2) ["case (multVals v1 v2) of"],
makeLine (indent + 3) ["Left v -> return $ push ", stateStr, "' (v)"],
makeLine (indent + 3) ["Right err -> throwError err ", stateStr],
makeLine (indent + 1) ["(Nothing, Just v2) -> ", "throwError \"Operator (*) error. Multiplication requires two operands; only one provided!\" ", stateStr],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError \"Operator (*) error. Multiplication requires two operands; none provided!\" ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "/" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "'", ", ", "secondToTop, ", "top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just v1, Just v2) -> "],
makeLine (indent + 2) ["case (divideVals v2 v1) of"],
makeLine (indent + 3) ["Left v -> return $ push ", stateStr, "' (v)"],
makeLine (indent + 3) ["Right err -> throwError err ", stateStr],
makeLine (indent + 1) ["(Nothing, Just v2) -> ", "throwError \"Operator (/) error. Division requires two operands; only one provided!\" ", stateStr],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError \"Operator (/) error. Division requires two operands; none provided!\" ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "swap" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "', ", "secondToTop, top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just v1, Just v2) -> return $ push (", "push ", stateStr, "' (v2)) (v1)"],
makeLine (indent + 1) ["(Nothing, Just v2) -> return ", stateStr],
makeLine (indent + 1) ["(Nothing, Nothing) -> return ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "drop" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let state", show $ stateCount + 1, " = fst $ pop ", stateStr]
]
in (codeLines, stateCount + 1)
generateOpCode "dropStack" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let state", show $ stateCount + 1,
" = EDState{stack = [], fns = fns ", stateStr, ", vars = vars ",
stateStr, ", frames = frames ", stateStr, ", heap = heap ", stateStr, "}"]
]
in (codeLines, stateCount + 1)
generateOpCode "rot" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "', thirdToTop, secondToTop, top) = pop3 ", stateStr],
makeLine indent ["newState <- case (thirdToTop, secondToTop, top) of"],
makeLine (indent + 1) ["(Just v1, Just v2, Just v3) -> return $ push (", "push (", "push ", stateStr, "' (v3)) (v1)) (v2)"],
makeLine (indent + 1) ["(Nothing, Just v2, Just v3) -> return $ push (", "push ", stateStr, "' (v3)) (v2)"],
makeLine (indent + 1) ["(Nothing, Nothing, Just v3) -> return $ ", stateStr],
makeLine (indent + 1) ["(Nothing, Nothing, Nothing) -> return $ ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "dup" indent stateCount =
let codeLines =
[
makeLine indent ["let (_, top) = pop state", show stateCount],
makeLine indent ["newState <- case top of"],
makeLine (indent + 1) ["Just v -> return $ push state", show stateCount, "(v)"],
makeLine (indent + 1) ["Nothing -> return state", show stateCount],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "==" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "', secondToTop, top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just v1, Just v2) ->"],
makeLine (indent + 2) ["case (doEqual v1 v2) of"],
makeLine (indent + 3) ["Left v -> return $ push ", stateStr, "' (v)"],
makeLine (indent + 3) ["Right err -> throwError err ", stateStr, "'"],
makeLine (indent + 1) ["(Nothing, Just v2) -> throwError \"Operator (==) error. Equality comparison requires two operands; only one provided!\"", stateStr, "'"],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError \"Operator (==) error. Equality comparison requires two operands; none provided!\"", stateStr, "'"],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "/=" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "', secondToTop, top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just v1, Just v2) ->"],
makeLine (indent + 2) ["case (doNotEqual v1 v2) of"],
makeLine (indent + 3) ["Left v -> return $ push ", stateStr, "' (v)"],
makeLine (indent + 3) ["Right err -> throwError err ", stateStr, "'"],
makeLine (indent + 1) ["(Nothing, Just v2) -> throwError \"Operator (/=) error. Inequality comparison requires two operands; only one provided!\"", stateStr, "'"],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError \"Operator (/=) error. Inequality comparison requires two operands; none provided!\"", stateStr, "'"],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode ">" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "', secondToTop, top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just v1, Just v2) -> "],
makeLine (indent + 2) ["case (doGreaterThan v1 v2) of"],
makeLine (indent + 3) ["Left v -> return $ push ", stateStr, "' (v)"],
makeLine (indent + 3) ["Right err -> throwError err ", stateStr, "'"],
makeLine (indent + 1) ["(Nothing, Just v2) -> throwError \"Operator (>) error. Greater than comparison requires two operands; only one provided!\" ", stateStr, "'"],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError \"Operator (>) error. Greater than comparison requires two operands; none provided!\" ", stateStr, "'"],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "<" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "', secondToTop, top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just v1, Just v2) -> "],
makeLine (indent + 2) ["case (doLessThan v1 v2) of"],
makeLine (indent + 3) ["Left v -> return $ push ", stateStr, "' (v)"],
makeLine (indent + 3) ["Right err -> throwError err ", stateStr, "'"],
makeLine (indent + 1) ["(Nothing, Just v2) -> throwError \"Operator (<) error. Less than comparison requires two operands; only one provided!\" ", stateStr, "'"],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError \"Operator (<) error. Less than comparison requires two operands; none provided!\" ", stateStr, "'"],
makeLine (indent) ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode ">=" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "', secondToTop, top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just v1, Just v2) -> "],
makeLine (indent + 2) ["case (doGreaterThanEqualTo v1 v2) of"],
makeLine (indent + 3) ["Left v -> return $ push ", stateStr, "' (v)"],
makeLine (indent + 3) ["Right err -> throwError err ", stateStr, "'"],
makeLine (indent + 1) ["(Nothing, Just v2) -> throwError \"Operator (>=) error. Greater than equal to comparison requires two operands; only one provided!\" ", stateStr, "'"],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError \"Operator (>=) error. Greater than equal to comparison requires two operands; none provided!\" ", stateStr, "'"],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "<=" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "', secondToTop, top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just v1, Just v2) -> "],
makeLine (indent + 2) ["case (doLessThanEqualTo v1 v2) of"],
makeLine (indent + 3) ["Left v -> return $ push ", stateStr, "' (v)"],
makeLine (indent + 3) ["Right err -> throwError err ", stateStr, "'"],
makeLine (indent + 1) ["(Nothing, Just v2) -> throwError \"Operator (<=) error. Less than equal to comparison requires two operands; only one provided!\" ", stateStr, "'"],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError \"Operator (<=) error. Less than equal to comparison requires two operands; none provided!\" ", stateStr, "'"],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "%" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "'", ", ", "secondToTop, ", "top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just v1, Just v2) -> "],
makeLine (indent + 2) ["case (doModulo v1 v2) of"],
makeLine (indent + 3) ["Left v -> return $ push ", stateStr, "' (v)"],
makeLine (indent + 3) ["Right err -> throwError err ", stateStr],
makeLine (indent + 1) ["(Nothing, Just v2) -> ", "throwError \"Operator (%) error. Modulo requires two operands; only one provided!\" ", stateStr],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError \"Operator (%) error. Modulo requires two operands; none provided!\" ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "++" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "'", ", ", "secondToTop, ", "top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just v1, Just v2) -> "],
makeLine (indent + 2) ["case (doConcat v1 v2) of"],
makeLine (indent + 3) ["Left v -> return $ push ", stateStr, "' (v)"],
makeLine (indent + 3) ["Right err -> throwError err ", stateStr],
makeLine (indent + 1) ["(Nothing, Just v2) -> ", "throwError \"Operator (++) error. Concatenation requires two operands; only one provided!\" ", stateStr],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError \"Operator (++) error. Concatenation requires two operands; none provided!\" ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "and" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "', secondToTop, top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just (Boolean b1), Just (Boolean b2)) -> return $ push ", stateStr, "' (Boolean $ b1 && b2)"],
makeLine (indent + 1) ["(Just v1, Just v2) -> let (v1Type, v2Type) = findTypeStrsForError v1 v2 in throwError (\"Operator (and) error. \
\Can't logically AND two items that are not both types of Boolean! Attempted types were: \" ++ v1Type ++ \" and \" ++ v2Type)", stateStr],
makeLine (indent + 1) ["(Nothing, Just v2) -> throwError \"Operator (and) error. Logical AND requires two operands; only one provided!\" ", stateStr],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError \"Operator (and) error. Logical AND requires two operands; none provided!\" ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "or" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "', secondToTop, top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just (Boolean b1), Just (Boolean b2)) -> return $ push ", stateStr, "' (Boolean $ b1 || b2)"],
makeLine (indent + 1) ["(Just v1, Just v2) -> let (v1Type, v2Type) = findTypeStrsForError v1 v2 in throwError (\"Operator (or) error. \
\Can't logically OR two items that are not both types of Boolean! Attempted types were: \" ++ v1Type ++ \" and \" ++ v2Type)", stateStr],
makeLine (indent + 1) ["(Nothing, Just v2) -> throwError \"Operator (or) error. Logical OR requires two operands; only one provided!\" ", stateStr],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError \"Operator (or) error. Logical OR requires two operands; none provided!\" ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "xor" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "', secondToTop, top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just (Boolean b1), Just (Boolean b2)) -> return $ push ", stateStr, "' (Boolean $ (b1 /= b2))"],
makeLine (indent + 1) ["(Just v1, Just v2) -> let (v1Type, v2Type) = findTypeStrsForError v1 v2 in throwError (\"Operator (xor) error. \
\Can't logically XOR two items that are not both types of Boolean! Attempted types were: \" ++ v1Type ++ \" and \" ++ v2Type)", stateStr],
makeLine (indent + 1) ["(Nothing, Just v2) -> throwError \"Operator (xor) error. Logical XOR requires two operands; only one provided!\" ", stateStr],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError \"Operator (xor) error. Logical XOR requires two operands; none provided!\" ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "not" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "', top) = pop ", stateStr],
makeLine indent ["newState <- case (top) of"],
makeLine (indent + 1) ["(Just (Boolean b1)) -> return $ push ", stateStr, "' (Boolean $ (not b1))"],
makeLine (indent + 1) ["(Just v1) -> let (v1Type) = chrs $ doQueryType' v1 in throwError (\"Operator (not) error. \
\Can't logically NOT item that isn't type Boolean! Attempted type was: \" ++ v1Type) ", stateStr],
makeLine (indent + 1) ["(Nothing) -> throwError \"Operator (not) error. Logical NOT operation requires one operand; none provided!\" ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "pow" indent stateCount =
let stateStr = "state" ++ (show stateCount)
codeLines =
[
makeLine indent ["let (", stateStr, "', secondToTop, top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just (Float f1), Just (Float f2)) -> return $ push ", stateStr, "' (Float $ f1 ** f2)"],
makeLine (indent + 1) ["(Just (Double d1), Just (Double d2)) -> return $ push ", stateStr, "' (Double $ d1 ** d2)"],
makeLine (indent + 1) ["(Just v1, Just v2) -> let (v1Type, v2Type) = findTypeStrsForError v1 v2 in throwError (\"Operator (pow) error. \
\Operands need to be both of type Float or Double! Attempted types: \" ++ v1Type ++ \" and \" ++ v2Type)", stateStr],
makeLine (indent + 1) ["(Nothing, Just v2) -> throwError \"Operator (pow) error. Two operands needed; only one provided!\" ", stateStr],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError \"Operator (pow) error. Two operands needed; none provided!\" ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "push" indent stateCount = makeListPushCode indent stateCount
generateOpCode "p" indent stateCount = makeListPushCode indent stateCount
generateOpCode "pop" indent stateCount = makeListPopCode indent stateCount
generateOpCode "po" indent stateCount = makeListPopCode indent stateCount
generateOpCode "fpush" indent stateCount = createListFrontPushCode indent stateCount
generateOpCode "fp" indent stateCount = createListFrontPushCode indent stateCount
generateOpCode "fpop" indent stateCount = createListFrontPopCode indent stateCount
generateOpCode "fpo" indent stateCount = createListFrontPopCode indent stateCount
generateOpCode "index" indent stateCount =
let stateStr = "state" ++ (show stateCount)
stateStr' = stateStr ++ "'"
codeLines =
[
makeLine indent ["let (", stateStr', ", secondToTop, top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just (List{items = is, len = l}), Just (Integer idx)) -> case (M.lookup idx is) of "],
makeLine (indent + 2) ["Just v -> return $ push (push ", stateStr', " (List{items = is, len = l})) v"],
makeLine (indent + 2) ["Nothing -> throwError (\"Operator (index) error. Index \" ++ (show idx) ++ \" out of valid range for List of size \" ++ (show l) ++ \"!\") ", stateStr'],
makeLine (indent + 1) ["(Just (String{chrs = cs, len = l}), Just (Integer idx)) -> if idx > -1 && idx < l \
\then return $ push (push ", stateStr', " String{chrs = cs, len = l}) (Char $ cs !! idx) ",
"else throwError (\"Operator (index) error. Index \" ++ (show idx) ++ \" out of valid range for String of size \" ++ (show l) ++ \"!\") ", stateStr'],
makeLine (indent + 1) ["(Just v1, Just v2) -> let (v1Type, v2Type) = findTypeStrsForError v1 v2 \
\in throwError (\"Operator (index) error. Index needs a List/String and an index value of type Integer! Attempted types: \" ++ v1Type ++ \" and \" ++ v2Type) ", stateStr'],
makeLine (indent + 1) ["(Nothing, Just v2) -> throwError (\"Operator (index) error. Two operands required for index; only one provided!\") ", stateStr'],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError (\"Operator (index) error. Two operands required for index; none provided!\") ", stateStr'],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "length" indent stateCount = generateLengthCode indent stateCount
generateOpCode "len" indent stateCount = generateLengthCode indent stateCount
generateOpCode "isEmpty" indent stateCount =
let stateStr = "state" ++ (show stateCount)
stateStr' = stateStr ++ "'"
codeLines =
[
makeLine indent ["let (", stateStr', ", top) = pop ", stateStr],
makeLine indent ["newState <- case top of"],
makeLine (indent + 1) ["Just (List{items = _, len = l}) -> return $ push ", stateStr, " (Boolean $ l == 0)"],
makeLine (indent + 1) ["Just (String{chrs = _, len = l}) -> return $ push ", stateStr, " (Boolean $ l == 0)"],
makeLine (indent + 1) ["Just (Object{fields = fs}) -> return $ push ", stateStr, " (Boolean $ M.null fs)"],
makeLine (indent + 1) ["Just v -> let vType = chrs $ doQueryType' v \
\in throwError (\"Operator (isEmpty) error. This operator is only valid for types of List/String/Object. Attempted type: \" ++ vType) ", stateStr],
makeLine (indent + 1) ["Nothing -> throwError (\"Operator (isEmpty) error. One operand needed; none provided!\") ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "clear" indent stateCount =
let stateStr = "state" ++ (show stateCount)
stateStr' = stateStr ++ "'"
codeLines =
[
makeLine indent ["let (", stateStr', ", top) = pop ", stateStr],
makeLine indent ["newState <- case top of"],
makeLine (indent + 1) ["Just (List{items = _, len = _}) -> return $ push ", stateStr', " (List{items = M.empty, len = 0})"],
makeLine (indent + 1) ["Just (String{chrs = _, len = _}) -> return $ push ", stateStr', " (String{chrs = \"\", len = 0})"],
makeLine (indent + 1) ["Just (Object{fields = fs}) -> return $ push ", stateStr', " (Object{fields = M.empty})"],
makeLine (indent + 1) ["Just v -> let vType = chrs $ doQueryType' v \
\in throwError (\"Operator (clear) error. Only type List/String/Object is valid for clear. Attempted type: \" ++ vType) ", stateStr],
makeLine (indent + 1) ["Nothing -> throwError (\"Operator (clear) error. One operand needed; none provided!\") ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "contains" indent stateCount =
let stateStr = "state" ++ (show stateCount)
stateStr' = stateStr ++ "'"
codeLines =
[
makeLine indent ["let (", stateStr', ", secondToTop, top) = pop2 ", stateStr],
makeLine indent ["newState <- case (secondToTop, top) of"],
makeLine (indent + 1) ["(Just (List{items = is, len = l}), Just v) -> return $ push ", stateStr, " (Boolean $ v `elem` is)"],
makeLine (indent + 1) ["(Just (String{chrs = cs, len = l}), Just (Char c)) -> return $ push ", stateStr, " (Boolean $ c `elem` cs)"],
makeLine (indent + 1) ["(Just (Object{fields = fs}), Just (String{chrs = name, len = l})) -> \
\let contains = case (M.lookup name fs) of ; Just _ -> True ; Nothing -> False ; in return $ push ", stateStr, " (Boolean contains) "],
makeLine (indent + 1) ["(Just v1, Just v2) -> let (v1Type, v2Type) = findTypeStrsForError v1 v2 \
\in throwError (\"Operator (contains) error. First pushed element must be a List/String/Object \
\and second item needs to be Value/Char/String respectively. Attempted types: \" ++ v1Type ++ \" and \" ++ v2Type) ", stateStr],
makeLine (indent + 1) ["(Nothing, Just v2) -> throwError (\"Operator (contains) error. Two operands on stack needed; only one provided!\") ", stateStr],
makeLine (indent + 1) ["(Nothing, Nothing) -> throwError (\"Operator (contains) error. Two operands on stack needed; none provided!\") ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "changeItemAt" indent stateCount =
let stateStr = "state" ++ (show stateCount)
stateStr' = stateStr ++ "'"
codeLines =
[
makeLine indent ["let (", stateStr', ", thirdToTop, secondToTop, top) = pop3 ", stateStr],
makeLine indent ["newState <- case (thirdToTop, secondToTop, top) of"],
makeLine (indent + 1) ["(Just (List{items = is, len = l}), Just v, Just (Integer idx)) -> "],
makeLine (indent + 2) ["if (idx > -1 && idx < l) \
\then return $ push ", stateStr', "(List{items = M.insert idx v is, len = l}) \
\else throwError (\"Operator (changeItemAt) error. Index \" ++ (show idx) \
\++ \" out of range for List of size \" ++ (show l) ++ \"!\") ", stateStr'],
makeLine (indent + 1) ["(Just v1, Just v2, Just v3) -> \
\let (v1Type, v2Type, v3Type) = (chrs $ doQueryType' v1, chrs $ doQueryType' v2, chrs $ doQueryType' v3)\
\ in throwError (\"Operator (changeItemAt) error. Top three items of stack need to be of type: \
\List Value Integer (ordered from bottom to top). \
\Attempted types: \" ++ v1Type ++ \", \" ++ v2Type ++ \", and \" ++ v3Type) ", stateStr],
makeLine (indent + 1) ["(Nothing, Just v2, Just v3) -> throwError (\"Operator (changeItemAt) error. Three operands needed; only two provided!\") ", stateStr],
makeLine (indent + 1) ["(Nothing, Nothing, Just v3) -> throwError (\"Operator (changeItemAt) error. Three operands needed; only one provided!\") ", stateStr],
makeLine (indent + 1) ["(Nothing, Nothing, Nothing) -> throwError (\"Operator (changeItemAt) error. Three operands needed; none provided!\") ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "isWhitespace" indent stateCount =
let stateStr = "state" ++ (show stateCount)
stateStr' = stateStr ++ "'"
codeLines =
[
makeLine indent ["let (", stateStr', ", top) = pop ", stateStr],
makeLine indent ["newState <- case top of"],
makeLine (indent + 1) ["Just (Char c) -> return $ push ", stateStr, " (Boolean $ isSpace c) "],
makeLine (indent + 1) ["Just v -> let vType = chrs $ doQueryType' v \
\in throwError (\"Operator (isWhitespace) error. Type on stack top needs to be of type Char. Attempted type: \" ++ vType) ", stateStr],
makeLine (indent + 1) ["Nothing -> throwError (\"Operator (isWhitespace) error. Operand on stack needed; none provided!\") ", stateStr],
makeLine indent ["let state", show $ stateCount + 1, " = newState"]
]
in (codeLines, stateCount + 1)
generateOpCode "cast" indent stateCount =
let stateStr = "state" ++ (show stateCount)
stateStr' = stateStr ++ "'"
codeLines =
[
makeLine indent ["let (", stateStr', ", secondToTop, top) = pop2 ", stateStr],
makeLine (indent) ["let castResult = case (secondToTop, top) of"],
makeLine (indent + 2) ["(Just (Boolean b), Just (String{chrs = \"Integer\", len = _})) -> Left $ Integer $ if b then 1 else 0"],
makeLine (indent + 2) ["(Just (Boolean b), Just (String{chrs = \"BigInteger\", len = _})) -> Left $ BigInteger $ if b then 1 else 0"],
makeLine (indent + 2) ["(Just (Boolean b), Just (String{chrs = \"String\", len = _})) -> let boolStr = show b in Left $ String{chrs = boolStr, len = length boolStr}"],
makeLine (indent + 2) ["(Just (Boolean b), Just (String{chrs = \"Boolean\", len = _})) -> Left $ Boolean b"],
makeLine (indent + 2) ["(Just (BigInteger n), Just (String{chrs = \"String\", len = _})) -> let bigIntStr = show n in Left $ String{chrs = bigIntStr, len = length bigIntStr}"],
makeLine (indent + 2) ["(Just (BigInteger n), Just (String{chrs = \"Integer\", len = _})) -> Left $ Integer (fromIntegral n :: Int)"],
makeLine (indent + 2) ["(Just (BigInteger n), Just (String{chrs = \"BigInteger\", len = _})) -> Left $ BigInteger n"],
makeLine (indent + 2) ["(Just (BigInteger n), Just (String{chrs = \"Float\", len = _})) -> Left $ Float (fromIntegral n :: Float)"],
makeLine (indent + 2) ["(Just (BigInteger n), Just (String{chrs = \"Double\", len = _})) -> Left $ Double (fromIntegral n :: Double)"],
makeLine (indent + 2) ["(Just (BigInteger n), Just (String{chrs = \"Char\", len = _})) -> let nInt = fromIntegral n :: Int \
\in if validIntToChar nInt \
\then Left $ Char $ chr nInt \
\else Right (\"Operator (cast) error. Failed to convert type BigInteger to Char. Try making sure the Integer is in the UTF-8 numerical range.\" \
\++ \" Given value: \" ++ (show n) ++ \" valid numbers are \" ++ (show $ ord minBound) ++ \" to \" ++ (show $ ord maxBound) ++ \".\")"],
makeLine (indent + 2) ["(Just (Integer n), Just (String{chrs = \"String\", len = _})) -> let intStr = show n in Left $ String{chrs = intStr, len = length intStr}"],
makeLine (indent + 2) ["(Just (Integer n), Just (String{chrs = \"Integer\", len = _})) -> Left $ Integer n"],
makeLine (indent + 2) ["(Just (Integer n), Just (String{chrs = \"BigInteger\", len = _})) -> Left $ BigInteger (fromIntegral n :: Integer)"],
makeLine (indent + 2) ["(Just (Integer n), Just (String{chrs = \"Float\", len = _})) -> Left $ Float (fromIntegral n :: Float)"],
makeLine (indent + 2) ["(Just (Integer n), Just (String{chrs = \"Double\", len = _})) -> Left $ Double (fromIntegral n :: Double)"],
makeLine (indent + 2) ["(Just (Integer n), Just (String{chrs = \"Char\", len = _})) -> if validIntToChar n \
\then Left $ Char $ chr n \
\else Right (\"Operator (cast) error. Failed to convert type Integer to Char. Try making sure the Integer is in the UTF-8 numerical range. \
\Given value: \" ++ (show n) ++ \" valid numbers are \" ++ (show $ ord minBound) ++ \" to \" ++ (show $ ord maxBound) ++ \".\") "],
makeLine (indent + 2) ["(Just (Float n), Just (String{chrs = \"String\", len = _})) -> let floatStr = show n in Left String{chrs = floatStr, len = length floatStr}"],
makeLine (indent + 2) ["(Just (Float n), Just (String{chrs = \"Integer\", len = _})) -> Left $ Integer $ truncate n"],
makeLine (indent + 2) ["(Just (Float n), Just (String{chrs = \"BigInteger\", len = _})) -> Left $ BigInteger (floor n :: Integer)"],
makeLine (indent + 2) ["(Just (Float n), Just (String{chrs = \"Float\", len = _})) -> Left $ Float n"],
makeLine (indent + 2) ["(Just (Float n), Just (String{chrs = \"Double\", len = _})) -> Left $ Double (realToFrac n :: Double)"],
makeLine (indent + 2) ["(Just (Double n), Just (String{chrs = \"String\", len = _})) -> let dblStr = show n in Left String{chrs = dblStr, len = length dblStr}"],
makeLine (indent + 2) ["(Just (Double n), Just (String{chrs = \"Integer\", len = _})) -> Left $ Integer (truncate n)"],
makeLine (indent + 2) ["(Just (Double n), Just (String{chrs = \"BigInteger\", len = _})) -> Left $ BigInteger (floor n :: Integer)"],
makeLine (indent + 2) ["(Just (Double n), Just (String{chrs = \"Float\", len = _})) -> Left $ Float (realToFrac n :: Float)"],
makeLine (indent + 2) ["(Just (Double n), Just (String{chrs = \"Double\", len = _})) -> Left $ Double n"],
makeLine (indent + 2) ["(Just (Char c), Just (String{chrs = \"String\", len = _})) -> let cStr = [c] in Left String{chrs = cStr, len = length cStr}"],
makeLine (indent + 2) ["(Just (Char c), Just (String{chrs = \"Integer\", len = _})) -> Left $ Integer $ ord c"],
makeLine (indent + 2) ["(Just (Char c), Just (String{chrs = \"BigInteger\", len = _})) -> Left $ BigInteger (fromIntegral (ord c) :: Integer)"],
makeLine (indent + 2) ["(Just (String{chrs = cs, len = l}), Just (String{chrs = \"String\", len = _})) -> Left $ String{chrs = cs, len = l}"],
makeLine (indent + 2) ["(Just (String{chrs = cs, len = l}), Just (String{chrs = \"Integer\", len = _})) -> case (readMaybe cs :: Maybe Int) of ; Just v -> Left $ Integer v ; \
\Nothing -> Right (\"Operator (cast) error. Failed to convert String '\" ++ cs ++ \"' to type Integer.\")"],
makeLine (indent + 2) ["(Just (String{chrs = cs, len = l}), Just (String{chrs = \"BigInteger\", len = _})) -> case (readMaybe cs :: Maybe Integer) of ; Just v -> Left $ BigInteger v ; \
\Nothing -> Right (\"Operator (cast) error. Failed to convert String '\" ++ cs ++ \"' to type BigInteger.\")"],
makeLine (indent + 2) ["(Just (String{chrs = cs, len = l}), Just (String{chrs = \"Float\", len = _})) -> case (readMaybe cs :: Maybe Float) of ; Just v -> Left $ Float v ; \
\Nothing -> Right (\"Operator (cast) error. Failed to convert String '\" ++ cs ++ \"' to type Float.\")"],
makeLine (indent + 2) ["(Just (String{chrs = cs, len = l}), Just (String{chrs = \"Double\", len = _})) -> case (readMaybe cs :: Maybe Double) of ; Just v -> Left $ Double v ; \
\Nothing -> Right (\"Operator (cast) error. Failed to convert String '\" ++ cs ++ \"' to type Double.\")"],
makeLine (indent + 2) ["(Just (List{items = is, len = l}), Just (String{chrs = \"String\", len = _})) -> \
\let listStr = (\"[\" ++ (printList List{items = is, len = l} \"\" 0 False) ++ \"]\") ; listStrLen = length listStr ; in Left $ String{chrs = listStr, len = listStrLen}"],
makeLine (indent + 2) ["(Just (Object{fields = fs}), Just (String{chrs = \"String\", len = _})) -> \
\let objStr = (\"{\" ++ (printObj (M.toList fs) \"\") ++ \"}\") ; objStrLen = length objStr ; in Left $ String{chrs = objStr, len = objStrLen}"],
makeLine (indent + 2) ["(Just (Box bn), Just (String{chrs = \"String\", len = _})) -> \
\let boxStr = if bn == (-1) then \"Box NULL\" else \"Box \" ++ (show bn) in Left $ String{chrs = boxStr, len = length boxStr} "],
makeLine (indent + 2) ["(Just (Box bn), Just (String{chrs = \"Integer\", len = _})) -> Left $ Integer bn"],
makeLine (indent + 2) ["(Just (Box bn), Just (String{chrs = \"Boolean\", len = _})) -> Left $ Boolean $ bn /= (-1)"],
makeLine (indent + 2) ["(Just (v), Just (String{chrs = typeCastStr, len = _})) -> let vType = chrs $ doQueryType' v \
\in Right (\"Operator (cast) error. Invalid casting configuration given! Tried to cast \" ++ vType ++ \" to type \" ++ typeCastStr)"],
makeLine (indent + 2) ["(Just v1, Just v2) -> let (v1Type, v2Type) = findTypeStrsForError v1 v2 \
\in Right (\"Operator (cast) error. Types of Value and String required for cast to occur. Attempted types: \" ++ v1Type ++ \" and \" ++ v2Type)"],
makeLine (indent + 2) ["(Nothing, Just v2) -> Right \"Operator (cast) error. Two operands required for cast; only one provided!\""],
makeLine (indent + 2) ["(Nothing, Nothing) -> Right \"Operator (cast) error. Two operands required for cast; none provided!\""],