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
|
{-# LANGUAGE LambdaCase #-}
module Evaluator (
evaluate,
) where
import qualified Data.Map as M
import qualified Data.List as L
import Data.Function ( on )
import Control.Monad.Reader
import Control.Monad.Except ( catchError )
import Utils
-- import Debug.Trace
type Depth = Int
_curryCall :: Env -> [AST] -> LFunction -> LContext AST
_curryCall _ [] f = return $ (makeNonsenseAST $ ASTFunction f)
_curryCall env (arg:[]) f = f env arg
_curryCall env (arg:rest) f = do
g <- _curryCall env rest f
case astNode g of
ASTFunction f' -> f' env arg
other -> throwL (astPos g) $ "cannot call value " ++ show other ++ " as a function"
curryCall :: Env -> [AST] -> LFunction -> LContext AST
curryCall env [] f = f env (makeNonsenseAST ASTUnit)
curryCall env args f = _curryCall env args f
traverseAndReplace :: String -> AST -> AST -> AST
traverseAndReplace param arg ast@AST { astNode = ASTSymbol sym }
| sym == param = arg
| otherwise = ast
traverseAndReplace param arg ast@AST { astNode = ASTFunctionCall body } =
ast { astNode = ASTFunctionCall $ (map (traverseAndReplace param arg) body) }
traverseAndReplace param arg ast@AST { astNode = ASTVector vec } =
ast { astNode = ASTVector $ (map (traverseAndReplace param arg) vec) }
traverseAndReplace param arg ast@AST { astNode = ASTHashMap hmap } =
ast { astNode = ASTHashMap $ M.assocs hmap
$> L.concatMap (\(a, b) -> [a, b])
.> map (traverseAndReplace param arg)
.> asPairs .> M.fromList }
traverseAndReplace _ _ other = other
foldSymValPairs :: [(String, AST)] -> AST -> AST
foldSymValPairs [] body = body
foldSymValPairs ((sym, val):rest) body =
let replacedRestVals = map (snd .> traverseAndReplace sym val) rest
replacedRest = zip (map fst rest) (replacedRestVals)
replacedBody = traverseAndReplace sym val body
in foldSymValPairs replacedRest replacedBody
letArgsToSymValPairs :: Depth -> Env -> [AST] -> LContext (String, AST)
letArgsToSymValPairs d env args =
case args of
[AST { astNode = ASTSymbol symbol' }, value'] -> do
(_, evaledValue) <- evaluate d env value'
return (symbol', evaledValue)
[AST { astNode = ASTSymbol "lazy" }, AST { astNode = ASTSymbol symbol' }, value'] -> do
return (symbol', value')
other -> throwL (astPos $ head other) $ "let! called with invalid args " ++ show other
defineUserFunction :: Depth -> AST -> [AST] -> LContext LFunction
defineUserFunction d AST { astNode = ASTSymbol param } exprs = return fn where
fn :: LFunction
fn env arg = do
let replacedExprs = map (traverseAndReplace param arg) exprs
let letExprs = take (length exprs - 1) replacedExprs
letSymValPairs <- letExprs
$> mapM (\case AST { astNode = ASTFunctionCall v } -> return $ drop 1 v
ast -> throwL (astPos ast) $ "unreachable: map letExprs, ast: " ++ show ast)
.> fmap (mapM $ letArgsToSymValPairs d env) .> join
let body = head $ drop (length exprs - 1) replacedExprs
let newBody = traverseAndReplace param arg body
$> foldSymValPairs letSymValPairs
(_, ret) <- evaluate d env newBody
return ret
defineUserFunction _ param exprs = throwL (astPos param)
$ "unreachable: defineUserFunction, param: " ++ show param ++ ", exprs: " ++ show exprs
defineUserFunctionWithLetExprs :: Depth -> [AST] -> [AST] -> LContext LFunction
defineUserFunctionWithLetExprs d [] exprs =
-- the position info is nonsensical, but it should never get read anyway
defineUserFunction d (makeNonsenseAST $ ASTSymbol "unit") exprs
defineUserFunctionWithLetExprs d (param:[]) exprs =
defineUserFunction d param exprs
defineUserFunctionWithLetExprs d (AST { astNode = ASTSymbol param }:rest) exprs = return fn where
fn :: LFunction
fn _ arg = do
let newExprs = map (traverseAndReplace param arg) exprs
ret <- defineUserFunctionWithLetExprs d rest newExprs
-- the returned AST will not have the correct position info, but that's fine
-- because the info is overridden in evaluateFunctionDef anyway
return $ makeNonsenseAST $ ASTFunction $ ret
defineUserFunctionWithLetExprs _ (param:_) _ = throwL (astPos $ param)
$ "unreachable: defineUserFunctionWithLetExprs, param: " ++ show param
evaluateFunctionDef :: Depth -> Env -> [AST] -> LContext (Env, AST)
evaluateFunctionDef d env asts = do
let defAst = head asts
args = tail asts
(params'', exprs) <- case args of
args'
| length args' < 2 ->
throwL (astPos defAst) $ "\\ called with " ++ show (length args) ++ " arguments"
| otherwise -> return $ (head args', tail args')
AST { astNode = ASTVector params' } <- assertIsASTVector params''
params <- mapM assertIsASTSymbol params'
let shadowingParamM = L.find (astNode .> (\(ASTSymbol sym) -> sym) .> isParamNameShadowing) params
case shadowingParamM of
Just shadowingParam -> throwL (astPos shadowingParam)
$ "parameter is shadowing already defined symbol " ++ show (astNode shadowingParam)
Nothing -> return ()
let letExprs = take (length exprs - 1) exprs
let nonLetExprM = L.find (not . isLetAST) letExprs
case nonLetExprM of
Just nonLetExpr -> throwL (astPos nonLetExpr)
$ "non-let expression in function definition before body: " ++ show nonLetExpr
Nothing -> return ()
fn <- defineUserFunctionWithLetExprs d params exprs
return $ (env, defAst { astNode = ASTFunction fn })
where
isLetAST AST { astNode = ASTFunctionCall (AST { astNode = ASTSymbol "let!" }:_) } = True
isLetAST _ = False
isParamNameShadowing name = M.member name env
evaluateMatch :: Depth -> Env -> [AST] -> LContext (Env, AST)
evaluateMatch d env asts = do
let matchAst = head asts
args = tail asts
(actualExpr, rest) <- case args of
[] -> throwL (astPos matchAst) $ "match called with no arguments"
(_:[]) -> throwL (astPos matchAst) "empty match cases"
(a:b) -> return (a, b)
pairs <- (asPairsM rest) `catchError`
(\_ -> throwL (astPos matchAst) $ "invalid number of arguments passed to match\n"
++ "- matching on expr: " ++ show actualExpr ++ "\n"
++ "- arguments: " ++ show rest)
(_, evaledActual) <- evaluate d env actualExpr
ret <- matchPairs (actualExpr, evaledActual) pairs
return (env, matchAst { astNode = astNode ret })
where
matchPairs :: (AST, AST) -> [(AST, AST)] -> LContext AST
matchPairs (actualExpr, evaledActual) [] = throwL (astPos actualExpr)
$ "matching case not found when matching on expression: " ++ show actualExpr
++ " (actual value: " ++ show evaledActual ++ ")"
matchPairs (actualExpr, evaledActual) ((matcher, branch):restPairs) = do
(_, evaledMatcher) <- evaluate d env matcher
if evaledActual == evaledMatcher
then do
(_, ret) <- evaluate d env branch
return ret
else matchPairs (actualExpr, evaledActual) restPairs
evaluateLet :: Depth -> Env -> [AST] -> LContext (Env, AST)
evaluateLet d env asts = do
let letAst = head asts
args = tail asts
when (d > 1) $ throwL (astPos letAst) $ "let! can only be called on the top level or in a function definition"
(symbol, value) <- letArgsToSymValPairs d env args
when (M.member symbol env) $ throwL (astPos letAst) $ "symbol already defined: " ++ symbol
let newEnv = M.insert symbol value env
return $ (newEnv, letAst { astNode = ASTUnit })
evaluateEnv :: Depth -> Env -> [AST] -> LContext (Env, AST)
evaluateEnv d env asts = do
let envAst = head asts
when (d > 1) $ throwL (astPos envAst) $ "env! can only be called on the top level or in a function definition"
let pairs = M.assocs env
let longestKey = L.maximumBy (compare `on` (length . fst)) pairs $> fst
let pad s = s ++ take (length longestKey + 4 - length s) (L.repeat ' ')
let rows = pairs $> map (\(k, v) -> pad k ++ show v)
liftIO $ mapM_ putStrLn rows
return (env, envAst { astNode = ASTUnit })
evaluateUserFunction :: Depth -> Env -> [AST] -> LContext (Env, AST)
evaluateUserFunction d env children = do
let fnAst = head children
args = tail children
(_, fnEvaled) <- evaluate d env fnAst
AST { astNode = (ASTFunction fn) } <- assertIsASTFunction fnEvaled
evaledArgs' <- mapM (evaluate d env) args
let evaledArgs = map snd evaledArgs'
doubleEvaledArgs' <- mapM (evaluate d env) evaledArgs
let doubleEvaledArgs = map snd doubleEvaledArgs'
result <- curryCall env (reverse doubleEvaledArgs) fn
-- maybe remove double eval here? can't remember why it was added
return (env, fnAst { astNode = astNode result })
evaluateSymbol :: Env -> AST -> LContext (Env, AST)
evaluateSymbol env ast@AST { astNode = ASTSymbol sym } = do
let val = M.lookup sym env
case val of
Just ast' -> return (env, ast')
Nothing -> throwL (astPos ast) $ "symbol " ++ sym ++ " not defined in environment"
evaluateSymbol _ ast = throwL (astPos ast) $ "unreachable: evaluateSymbol, ast: " ++ show ast
evaluate :: Depth -> Env -> AST -> LContext (Env, AST)
evaluate d env AST { astNode = fnc@(ASTFunctionCall args@(x:_)) } =
do config <- ask
when (configPrintCallStack config) $ liftIO $ putStrLn $ "fn call: " ++ show fnc
case astNode x of
-- remember to add these as reseved keywords in Builtins!
ASTSymbol "\\" ->
evaluateFunctionDef (d + 1) env args
ASTSymbol "match" ->
evaluateMatch (d + 1) env args
ASTSymbol "let!" ->
evaluateLet (d + 1) env args
ASTSymbol "env!" ->
evaluateEnv (d + 1) env args
_ ->
evaluateUserFunction (d + 1) env args
evaluate _ env ast@AST { astNode = (ASTSymbol _) } =
evaluateSymbol env ast
evaluate d env ast@AST { astNode = (ASTVector vec) } =
do rets <- mapM (evaluate (d + 1) env) vec
let vec' = map snd rets
return $ (env, ast { astNode = ASTVector vec' })
evaluate _ env other =
return (env, other)
|
