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
|
{-# LANGUAGE LambdaCase #-}
module Evaluator (
evaluate,
) where
import qualified Data.Map as M
import qualified Data.List as L
import Control.Monad.Except
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
evalLetExpr :: Env -> [AST] -> LContext (String, AST)
evalLetExpr 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
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
makeUserDefFn :: AST -> [AST] -> LFunction
makeUserDefFn (ASTSymbol param) exprs =
let fn :: LFunction
fn env arg = do
let replacedExprs = map (traverseAndReplace param arg) exprs
let letExprs = take (length exprs - 1) replacedExprs
letSymValPairs <- letExprs
$> map (\case (ASTFunctionCall v) -> drop 1 v
_ -> error $ "unreachable: map letExprs")
.> mapM (evalLetExpr env)
let body = head $ drop (length exprs - 1) replacedExprs
let newBody = traverseAndReplace param arg body
$> foldSymValPairs letSymValPairs
(_, ret) <- evaluate env newBody
return ret
in fn
makeUserDefFn _ _ = error $ "unreachable: makeUserDefFn"
curriedMakeUserDefFn :: [AST] -> [AST] -> LFunction
curriedMakeUserDefFn [] exprs = makeUserDefFn (ASTSymbol "_") exprs
curriedMakeUserDefFn (param:[]) exprs = makeUserDefFn param exprs
curriedMakeUserDefFn ((ASTSymbol param):rest) exprs =
let fn :: LFunction
fn _ arg = do
let newExprs = map (traverseAndReplace param arg) exprs
let ret = curriedMakeUserDefFn rest newExprs
return $ ASTFunction $ ret
in fn
curriedMakeUserDefFn _ _ = error $ "unreachable: curriedMakeUserDefFn"
evaluate :: Env -> AST -> LContext (Env, AST)
evaluate env (ASTFunctionCall (first:args))
| first == ASTSymbol "\\" = 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"
let fn = curriedMakeUserDefFn params exprs
return $ (env, ASTFunction fn)
| first == ASTSymbol "match" = do
(cond, 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
(_, evaledCond) <- evaluate env cond
case M.lookup evaledCond caseMap of
Just branch -> evaluate env branch
Nothing -> throwL $ "matching case not found when matching on value: " ++ show cond
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
(_, evaledCond) <- evaluate env cond
case M.lookup evaledCond caseMap of
Just branch -> evaluate env branch
Nothing -> evaluate env defaultBranch
| first == ASTSymbol "let" = do
(symbol, value) <- evalLetExpr env args
when (M.member symbol env) $ throwL $ "symbol already defined: " ++ symbol
let newEnv = M.insert symbol value env
return $ (newEnv, ASTUnit)
| first == ASTSymbol "env" = do
liftIO $ putStrLn $ show env
return (env, ASTUnit)
| otherwise = do
(_, fnEvaled) <- evaluate env first
(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)
evaluate env (ASTSymbol 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 = return (env, ast)
|
