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
|
module Lib (
runScriptFile,
runInlineScript,
) where
import qualified Data.Map as M
import qualified Data.Bifunctor as B
import qualified Data.List as L
import Control.Monad.Except
import Control.Monad.Reader
import Text.Regex.TDFA
import Types
import Utils
import Debug.Trace
_tokenize :: [String] -> String -> String -> LContext [String]
_tokenize acc current src = case src of
"" -> return $ reverse current : acc
(x:xs)
| x == ';' ->
let commentDropped = dropWhile (\c -> c /= '\n') xs
in _tokenize (reverse current : acc) "" commentDropped
| x == '"' ->
-- String length -1 signals an unbalanced error
let inc k n = if n == -1 then -1 else n + k
consume :: String -> (String, Int)
consume str = case str of
('\\':'"':rest) -> B.bimap ('\"' :) (inc 2) (consume rest)
('\\':'n':rest) -> B.bimap ('\n' :) (inc 2) (consume rest)
('\\':'t':rest) -> B.bimap ('\t' :) (inc 2) (consume rest)
('"':_) -> ("", 1)
(c:rest) -> B.bimap (c :) (inc 1) (consume rest)
[] -> ("", -1)
(string, stringLength) = consume xs
stringDropped = drop (stringLength) xs
withQuotes = "\"" ++ string ++ "\""
in do
when (stringLength == -1) $ throwError (LException "Unbalanced string literal")
_tokenize (withQuotes : acc) "" stringDropped
| x `elem` [' ', '\n', '\t', '\r'] ->
_tokenize (reverse current : acc) "" xs
| x `elem` ['(', ')', '[', ']', '{', '}', '\\'] ->
_tokenize ([x] : reverse current : acc) "" xs
| otherwise ->
_tokenize acc (x : current) xs
tokenize :: String -> LContext [String]
tokenize src = do
tokens <- _tokenize [] "" src
return $ tokens
$> reverse
.> filter (\s -> length s > 0)
validateBalance :: [String] -> [AST] -> LContext [AST]
validateBalance allowed asts = do
when (ASTSymbol "(" `elem` asts && "(" `notElem` allowed)
$ throwError $ LException "Unbalanced function call"
when (ASTSymbol "[" `elem` asts && "[" `notElem` allowed)
$ throwError $ LException "Unbalanced vector"
when (ASTSymbol "{" `elem` asts && "{" `notElem` allowed)
$ throwError $ LException "Unbalanced hash map"
return asts
asPairsM :: [a] -> LContext [(a, a)]
asPairsM [] = return []
asPairsM (a:b:rest) = do
restPaired <- asPairsM rest
return $ (a, b) : restPaired
asPairsM _ = throwError $ LException "Odd number of elements to pair up"
asPairs :: [a] -> [(a, a)]
asPairs [] = []
asPairs (a:b:rest) =
let restPaired = asPairs rest
in (a, b) : restPaired
asPairs _ = error "Odd number of elements to pair up"
parseToken :: String -> AST
parseToken token
| isInteger token = ASTInteger (read token)
| isDouble token = ASTDouble (read token)
| isString token = ASTString $ removeQuotes token
| isBoolean token = ASTBoolean $ asBoolean token
| otherwise = ASTSymbol token
where
integerRegex = "^-?[[:digit:]]+$"
isInteger :: String -> Bool
isInteger t = t =~ integerRegex
doubleRegex = "^-?[[:digit:]]+(\\.[[:digit:]]+)?$"
isDouble :: String -> Bool
isDouble t = t =~ doubleRegex
isString t = "\"" `L.isPrefixOf` t
removeQuotes s = drop 1 s $> take (length s - 2)
isBoolean t = t `elem` ["true", "false"]
asBoolean t = if t == "true" then True else False
_parse :: [AST] -> [String] -> LContext [AST]
_parse acc' [] = do
acc <- validateBalance [] acc'
return $ reverse acc
_parse acc (")":rest) = do
let children' = takeWhile (/= ASTSymbol "(") acc
children <- validateBalance ["("] children'
let fnCall = ASTFunctionCall (reverse children)
let newAcc = fnCall : drop (length children + 1) acc
_parse newAcc rest
_parse acc ("]":rest) = do
let children' = takeWhile (/= ASTSymbol "[") acc
children <- validateBalance ["["] children'
let vec = ASTVector (reverse children)
let newAcc = vec : drop (length children + 1) acc
_parse newAcc rest
_parse acc ("}":rest) = do
let children' = takeWhile (/= ASTSymbol "{") acc
children <- validateBalance ["{"] children'
pairs <- asPairsM $ reverse children
let vec = ASTHashMap (M.fromList pairs)
let newAcc = vec : drop (length children + 1) acc
_parse newAcc rest
_parse acc (token:rest) =
_parse (parseToken token : acc) rest
parse :: [String] -> LContext [AST]
parse = _parse []
assertFunctionAST :: AST -> LContext AST
assertFunctionAST ast = case ast of
(ASTFunction _) -> return ast
_ -> throwError $ LException $ show ast ++ " is not a function"
assertIntegerAST :: AST -> LContext AST
assertIntegerAST ast = case ast of
(ASTInteger _) -> return ast
_ -> throwError $ LException $ show ast ++ " is not an integer"
curryCall :: [AST] -> (AST -> LContext AST) -> LContext AST
curryCall [] f = return $ ASTFunction f
curryCall (arg:[]) f = f arg
curryCall (arg:rest) f = do
g <- curryCall rest f
case g of
ASTFunction f' -> f' arg
other -> throwError $ LException $ "Cannot call value " ++ show other ++ " as a function"
type Env = M.Map String AST
builtinEnv :: Env
builtinEnv = M.fromList [
("sum2", builtinSum2)
]
traverseAndReplace :: String -> AST -> AST -> AST
traverseAndReplace param arg ast@(ASTSymbol sym)
| sym == param = arg
| otherwise = ast
traverseAndReplace param arg (ASTFunctionCall body) =
ASTFunctionCall $ (map (traverseAndReplace param arg) body)
traverseAndReplace param arg (ASTVector vec) =
ASTVector $ (map (traverseAndReplace param arg) vec)
traverseAndReplace param arg (ASTHashMap hmap) =
ASTHashMap $ M.assocs hmap
$> L.concatMap (\(a, b) -> [a, b])
.> map (traverseAndReplace param arg)
.> asPairs .> M.fromList
traverseAndReplace _ _ other = other
makeUserDefFn :: Env -> String -> AST -> AST -> LContext AST
makeUserDefFn env param body =
let fn :: AST -> LContext AST
fn arg = do
let newBody = traverseAndReplace param arg body
evaluate env newBody
in fn
builtinSum2 :: AST
builtinSum2 =
let outer ast1 = do
(ASTInteger a) <- assertIntegerAST ast1
let inner ast2 = do
(ASTInteger b) <- assertIntegerAST ast2
return $ ASTInteger $ a + b
return $ ASTFunction $ inner
in ASTFunction outer
evaluate :: Env -> AST -> LContext AST
evaluate env (ASTFunctionCall children@(first:args))
| first == ASTSymbol "\\" = do
-- throwError $ LException "function def not implemented"
-- let (ASTVector paramList : ASTFunctionCall body : []) = args
let (ASTVector [ASTSymbol param] : body : []) = args
let fn = makeUserDefFn env param body
return $ ASTFunction fn
-- return $ ASTFunction fn
| first == ASTSymbol "match" =
throwError $ LException "match not implemented"
| otherwise = do
fnEvaled <- evaluate env first
(ASTFunction fn) <- assertFunctionAST fnEvaled
evaledArgs <- mapM (evaluate env) args
result <- curryCall (reverse evaledArgs) fn
return result
evaluate env (ASTSymbol sym) = do
let val = M.lookup sym env
case val of
Just ast -> return ast
Nothing -> throwError $ LException $ "Symbol " ++ sym ++ " not defined in environment"
evaluate _ ast = return ast
runScriptFile :: String -> LContext ()
runScriptFile fileName = do
src <- liftIO $ readFile fileName
runInlineScript src
runInlineScript :: String -> LContext ()
runInlineScript src = do
tokenized <- tokenize src
config <- ask
when (configVerboseMode config) $ liftIO $ putStrLn $ "tokenized:\t\t" ++ show tokenized
parsed <- parse tokenized
when (configVerboseMode config) $ do
let output = "parsed:\t\t\t" ++ (map show parsed $> L.intercalate "\n\t\t\t")
liftIO $ putStrLn output
evaluated <- mapM (evaluate builtinEnv) parsed
liftIO $ mapM_ putStrLn (map show evaluated)
|
