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
|
{-# 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 Utils
_curryCall :: Env -> [AST] -> LFunction -> LContext AST
_curryCall _ [] f = return $ ASTFunction f
_curryCall env (arg:[]) f = f env arg
_curryCall env (arg:rest) f = do
g <- _curryCall env rest f
case g of
ASTFunction f' -> f' env arg
other -> throwL $ "cannot call value " ++ show other ++ " as a function"
curryCall :: Env -> [AST] -> LFunction -> LContext AST
curryCall env [] f = f env ASTUnit
curryCall env args f = _curryCall env 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
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 :: Env -> [AST] -> LContext (String, AST)
letArgsToSymValPairs env args =
case args of
[ASTSymbol symbol', value'] -> do
(_, evaledValue) <- evaluate env value'
return (symbol', evaledValue)
[ASTSymbol "lazy", ASTSymbol symbol', value'] -> do
return (symbol', value')
other -> throwL $ "let called with invalid args " ++ show other
defineUserFunction :: AST -> [AST] -> LContext LFunction
defineUserFunction (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 (ASTFunctionCall v) -> return $ drop 1 v
_ -> throwL $ "unreachable: map letExprs")
.> fmap (mapM $ letArgsToSymValPairs env) .> join
let body = head $ drop (length exprs - 1) replacedExprs
let newBody = traverseAndReplace param arg body
$> foldSymValPairs letSymValPairs
(_, ret) <- evaluate env newBody
return ret
defineUserFunction _ _ = throwL $ "unreachable: defineUserFunction"
defineUserFunctionWithLetExprs :: [AST] -> [AST] -> LContext LFunction
defineUserFunctionWithLetExprs [] exprs =
defineUserFunction (ASTSymbol "_") exprs
defineUserFunctionWithLetExprs (param:[]) exprs =
defineUserFunction param exprs
defineUserFunctionWithLetExprs ((ASTSymbol param):rest) exprs = return fn where
fn :: LFunction
fn _ arg = do
let newExprs = map (traverseAndReplace param arg) exprs
ret <- defineUserFunctionWithLetExprs rest newExprs
return $ ASTFunction $ ret
defineUserFunctionWithLetExprs _ _ = throwL $ "unreachable: defineUserFunctionWithLetExprs"
evaluateFunctionDef :: Env -> [AST] -> LContext (Env, AST)
evaluateFunctionDef env args = do
(params'', exprs) <- case args of
args'
| length args' < 2 ->
throwL $ "\\ called with " ++ show (length args) ++ " arguments"
| otherwise -> return $ (head args', tail args')
(ASTVector params') <- assertIsASTVector params''
params <- mapM assertIsASTSymbol params'
let letExprs = take (length exprs - 1) exprs
when (any (\case ASTFunctionCall (ASTSymbol "let":_) -> False; _ -> True) letExprs)
$ throwL "non-let expression in function definition before body"
fn <- defineUserFunctionWithLetExprs params exprs
return $ (env, ASTFunction fn)
evaluateMatch :: Env -> [AST] -> LContext (Env, AST)
evaluateMatch env args = do
(actual, rest) <- case args of
[] -> throwL $ "match called with no arguments"
(_:[]) -> throwL $ "empty match cases"
(a:b) -> return (a, b)
if length rest `mod` 2 == 0
then do
caseMatchers' <- oddElems rest $> mapM (evaluate env)
let caseMatchers = map snd caseMatchers'
let caseBranches = evenElems rest
let caseMap = M.fromList $ L.zip caseMatchers caseBranches
(_, evaledActual) <- evaluate env actual
case M.lookup evaledActual caseMap of
Just branch -> evaluate env branch
Nothing -> throwL $ "matching case not found when matching on expression: " ++ show actual
++ " (actual value: " ++ show evaledActual ++ ")"
else do
let (defaultBranch, revCases) = case reverse rest of
(a:b) -> (a, b)
_ -> error $ "unreachable: reverse rest"
caseMatchers' <- oddElems (reverse revCases) $> mapM (evaluate env)
let caseMatchers = map snd caseMatchers'
let caseBranches = evenElems (reverse revCases)
let caseMap = M.fromList $ L.zip caseMatchers caseBranches
(_, evaledActual) <- evaluate env actual
case M.lookup evaledActual caseMap of
Just branch -> evaluate env branch
Nothing -> evaluate env defaultBranch
evaluateLet :: Env -> [AST] -> LContext (Env, AST)
evaluateLet env args = do
(symbol, value) <- letArgsToSymValPairs env args
when (M.member symbol env) $ throwL $ "symbol already defined: " ++ symbol
let newEnv = M.insert symbol value env
return $ (newEnv, ASTUnit)
evaluateEnv :: Env -> LContext (Env, AST)
evaluateEnv env = do
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, ASTUnit)
evaluateUserFunction :: Env -> [AST] -> LContext (Env, AST)
evaluateUserFunction env children = do
let fnName = head children
let args = tail children
(_, fnEvaled) <- evaluate env fnName
(ASTFunction fn) <- assertIsASTFunction fnEvaled
evaledArgs' <- mapM (evaluate env) args
let evaledArgs = map snd evaledArgs'
doubleEvaledArgs' <- mapM (evaluate env) evaledArgs
let doubleEvaledArgs = map snd doubleEvaledArgs'
result <- curryCall env (reverse doubleEvaledArgs) fn
return (env, result)
evaluateSymbol :: Env -> String -> LContext (Env, AST)
evaluateSymbol env sym = do
let val = M.lookup sym env
case val of
Just ast -> return (env, ast)
Nothing -> throwL $ "symbol " ++ sym ++ " not defined in environment"
evaluate :: Env -> AST -> LContext (Env, AST)
evaluate env fnc@(ASTFunctionCall (first:args)) =
do config <- ask
when (configPrintCallStack config) $ liftIO $ putStrLn $ "fn call: " ++ show fnc
case first of
ASTSymbol "\\" ->
evaluateFunctionDef env args
ASTSymbol "match" ->
evaluateMatch env args
ASTSymbol "let" ->
evaluateLet env args
ASTSymbol "env" ->
evaluateEnv env
_ ->
evaluateUserFunction env (first:args)
evaluate env (ASTSymbol sym) =
evaluateSymbol env sym
evaluate env (ASTVector vec) =
do rets <- mapM (evaluate env) vec
let vec' = map snd rets
return $ (env, ASTVector vec')
evaluate env other =
return (env, other)
|
