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
|
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 Builtins
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 []
_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"
curryCall :: [AST] -> (AST -> LContext AST) -> LContext AST
curryCall [] f = f ASTUnit
curryCall args f = _curryCall args f
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 -> AST -> AST -> AST -> LContext AST
makeUserDefFn env (ASTSymbol param) body =
let fn :: AST -> LContext AST
fn arg = do
let newBody = traverseAndReplace param arg body
evaluate env newBody
in fn
makeUserDefFn _ _ _ = error $ "unreachable: makeUserDefFn"
curriedMakeUserDefFn :: Env -> [AST] -> AST -> AST -> LContext AST
curriedMakeUserDefFn env [] body = makeUserDefFn env (ASTSymbol "_") body
curriedMakeUserDefFn env (param:[]) body = makeUserDefFn env param body
curriedMakeUserDefFn env ((ASTSymbol param):rest) body =
let fn :: AST -> LContext AST
fn arg = do
let newBody = traverseAndReplace param arg body
let ret = curriedMakeUserDefFn env rest newBody
return $ ASTFunction $ ret
in fn
curriedMakeUserDefFn _ _ _ = error $ "unreachable: curriedMakeUserDefFn"
evaluate :: Env -> AST -> LContext AST
evaluate env (ASTFunctionCall (first:args))
| first == ASTSymbol "\\" = do
(arg1, arg2) <- case args of
[arg1', arg2'] -> return (arg1', arg2')
_ -> throwError $ LException $ "\\ called with " ++ show (length args) ++ " arguments"
(ASTVector params') <- assertIsASTVector arg1
params <- mapM assertIsASTSymbol params'
-- when (length params == 0) $ throwError $ LException $ "Function must have > 0 parameters"
body <- assertIsASTFunctionCall arg2
let fn = curriedMakeUserDefFn env params body
return $ ASTFunction fn
| first == ASTSymbol "match" = do
(cond, rest) <- case args of
[] -> throwError $ LException $ "match called with no arguments"
(_:[]) -> throwError $ LException $ "empty match cases"
(cond':rest') -> return (cond', rest')
if length rest `mod` 2 == 0
then do
caseMatchers <- oddElems rest $> mapM (evaluate env)
let caseBranches = evenElems rest
let caseMap = M.fromList $ L.zip caseMatchers caseBranches
evaledCond <- evaluate env cond
case M.lookup evaledCond caseMap of
Just branch -> evaluate env branch
Nothing -> throwError $ LException $ "matching case not found, condition " ++ show cond
else do
let (defaultBranch:revCases) = reverse rest
caseMatchers <- oddElems (reverse revCases) $> mapM (evaluate env)
let caseBranches = evenElems (reverse revCases)
let caseMap = M.fromList $ L.zip caseMatchers caseBranches
evaledCond <- evaluate env cond
case M.lookup evaledCond caseMap of
Just branch -> evaluate env branch
Nothing -> evaluate env defaultBranch
| otherwise = do
fnEvaled <- evaluate env first
(ASTFunction fn) <- assertIsASTFunction 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)
|
