Commit | Line | Data |
---|---|---|
5400d4bf | 1 | import System.IO (hFlush, stdout) |
2988d38e | 2 | import System.Environment (getArgs) |
5400d4bf JM |
3 | import Control.Monad (mapM) |
4 | import Control.Monad.Error (runErrorT) | |
5 | import Control.Monad.Trans (liftIO) | |
2988d38e JM |
6 | import qualified Data.Map as Map |
7 | import qualified Data.Traversable as DT | |
8 | ||
9 | import Readline (readline, load_history) | |
10 | import Types | |
11 | import Reader (read_str) | |
12 | import Printer (_pr_str) | |
13 | import Env (Env, env_new, env_bind, env_get, env_set) | |
14 | import Core as Core | |
15 | ||
16 | -- read | |
5400d4bf | 17 | mal_read :: String -> IOThrows MalVal |
2988d38e JM |
18 | mal_read str = read_str str |
19 | ||
20 | -- eval | |
c150ec41 JM |
21 | is_pair (MalList x _:xs) = True |
22 | is_pair (MalVector x _:xs) = True | |
2988d38e JM |
23 | is_pair _ = False |
24 | ||
25 | quasiquote :: MalVal -> MalVal | |
26 | quasiquote ast = | |
27 | case ast of | |
c150ec41 JM |
28 | (MalList (MalSymbol "unquote" : a1 : []) _) -> a1 |
29 | (MalList (MalList (MalSymbol "splice-unquote" : a01 : []) _ : rest) _) -> | |
30 | MalList [(MalSymbol "concat"), a01, quasiquote (MalList rest Nil)] Nil | |
31 | (MalVector (MalList (MalSymbol "splice-unquote" : a01 : []) _ : rest) _) -> | |
32 | MalList [(MalSymbol "concat"), a01, quasiquote (MalVector rest Nil)] Nil | |
33 | (MalList (a0 : rest) _) -> MalList [(MalSymbol "cons"), | |
2988d38e | 34 | quasiquote a0, |
c150ec41 JM |
35 | quasiquote (MalList rest Nil)] Nil |
36 | (MalVector (a0 : rest) _) -> MalList [(MalSymbol "cons"), | |
37 | quasiquote a0, | |
38 | quasiquote (MalVector rest Nil)] Nil | |
39 | _ -> MalList [(MalSymbol "quote"), ast] Nil | |
2988d38e JM |
40 | |
41 | ||
5400d4bf | 42 | eval_ast :: MalVal -> Env -> IOThrows MalVal |
2988d38e | 43 | eval_ast sym@(MalSymbol _) env = env_get env sym |
c150ec41 | 44 | eval_ast ast@(MalList lst m) env = do |
2988d38e | 45 | new_lst <- mapM (\x -> (eval x env)) lst |
c150ec41 JM |
46 | return $ MalList new_lst m |
47 | eval_ast ast@(MalVector lst m) env = do | |
2988d38e | 48 | new_lst <- mapM (\x -> (eval x env)) lst |
c150ec41 JM |
49 | return $ MalVector new_lst m |
50 | eval_ast ast@(MalHashMap lst m) env = do | |
2988d38e | 51 | new_hm <- DT.mapM (\x -> (eval x env)) lst |
c150ec41 | 52 | return $ MalHashMap new_hm m |
2988d38e JM |
53 | eval_ast ast env = return ast |
54 | ||
5400d4bf | 55 | let_bind :: Env -> [MalVal] -> IOThrows Env |
2988d38e JM |
56 | let_bind env [] = return env |
57 | let_bind env (b:e:xs) = do | |
58 | evaled <- eval e env | |
5400d4bf | 59 | x <- liftIO $ env_set env b evaled |
2988d38e JM |
60 | let_bind env xs |
61 | ||
5400d4bf | 62 | apply_ast :: MalVal -> Env -> IOThrows MalVal |
c150ec41 | 63 | apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do |
2988d38e JM |
64 | case args of |
65 | (a1@(MalSymbol _): a2 : []) -> do | |
66 | evaled <- eval a2 env | |
5400d4bf JM |
67 | liftIO $ env_set env a1 evaled |
68 | _ -> throwStr "invalid def!" | |
c150ec41 | 69 | apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do |
2988d38e | 70 | case args of |
c150ec41 JM |
71 | (a1 : a2 : []) -> do |
72 | params <- (_to_list a1) | |
5400d4bf | 73 | let_env <- liftIO $ env_new $ Just env |
c150ec41 | 74 | let_bind let_env params |
2988d38e | 75 | eval a2 let_env |
5400d4bf | 76 | _ -> throwStr "invalid let*" |
c150ec41 | 77 | apply_ast ast@(MalList (MalSymbol "quote" : args) _) env = do |
2988d38e JM |
78 | case args of |
79 | a1 : [] -> return a1 | |
5400d4bf | 80 | _ -> throwStr "invalid quote" |
c150ec41 | 81 | apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do |
2988d38e JM |
82 | case args of |
83 | a1 : [] -> eval (quasiquote a1) env | |
5400d4bf | 84 | _ -> throwStr "invalid quasiquote" |
c150ec41 | 85 | apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do |
2988d38e JM |
86 | case args of |
87 | ([]) -> return Nil | |
88 | _ -> do | |
c150ec41 | 89 | el <- eval_ast (MalList args Nil) env |
2988d38e | 90 | case el of |
c150ec41 | 91 | (MalList lst _) -> return $ last lst |
2988d38e | 92 | |
c150ec41 | 93 | apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do |
2988d38e JM |
94 | case args of |
95 | (a1 : a2 : a3 : []) -> do | |
96 | cond <- eval a1 env | |
97 | if cond == MalFalse || cond == Nil | |
98 | then eval a3 env | |
99 | else eval a2 env | |
100 | (a1 : a2 : []) -> do | |
101 | cond <- eval a1 env | |
102 | if cond == MalFalse || cond == Nil | |
103 | then return Nil | |
104 | else eval a2 env | |
5400d4bf | 105 | _ -> throwStr "invalid if" |
c150ec41 JM |
106 | apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do |
107 | case args of | |
108 | (a1 : a2 : []) -> do | |
109 | params <- (_to_list a1) | |
110 | return $ (_malfunc a2 env (MalList params Nil) | |
111 | (\args -> do | |
5400d4bf JM |
112 | fn_env1 <- liftIO $ env_new $ Just env |
113 | fn_env2 <- liftIO $ env_bind fn_env1 params args | |
c150ec41 | 114 | eval a2 fn_env2)) |
5400d4bf | 115 | _ -> throwStr "invalid fn*" |
c150ec41 | 116 | apply_ast ast@(MalList _ _) env = do |
2988d38e JM |
117 | el <- eval_ast ast env |
118 | case el of | |
c150ec41 | 119 | (MalList ((Func (Fn f) _) : rest) _) -> |
2988d38e | 120 | f $ rest |
c150ec41 | 121 | (MalList ((MalFunc {ast=ast, env=fn_env, params=(MalList params Nil)}) : rest) _) -> do |
5400d4bf JM |
122 | fn_env1 <- liftIO $ env_new $ Just fn_env |
123 | fn_env2 <- liftIO $ env_bind fn_env1 params rest | |
2988d38e JM |
124 | eval ast fn_env2 |
125 | el -> | |
5400d4bf | 126 | throwStr $ "invalid apply: " ++ (show el) |
2988d38e | 127 | |
5400d4bf | 128 | eval :: MalVal -> Env -> IOThrows MalVal |
2988d38e JM |
129 | eval ast env = do |
130 | case ast of | |
c150ec41 | 131 | (MalList _ _) -> apply_ast ast env |
2988d38e JM |
132 | _ -> eval_ast ast env |
133 | ||
134 | ||
135 | ||
136 | mal_print :: MalVal -> String | |
137 | mal_print exp = show exp | |
138 | ||
139 | -- repl | |
140 | ||
5400d4bf | 141 | rep :: Env -> String -> IOThrows String |
2988d38e JM |
142 | rep env line = do |
143 | ast <- mal_read line | |
144 | exp <- eval ast env | |
145 | return $ mal_print exp | |
146 | ||
147 | repl_loop :: Env -> IO () | |
148 | repl_loop env = do | |
149 | line <- readline "user> " | |
150 | case line of | |
151 | Nothing -> return () | |
152 | Just "" -> repl_loop env | |
153 | Just str -> do | |
5400d4bf JM |
154 | res <- runErrorT $ rep env str |
155 | out <- case res of | |
156 | Left (StringError str) -> return $ "Error: " ++ str | |
157 | Left (MalValError mv) -> return $ "Error: " ++ (show mv) | |
158 | Right val -> return val | |
2988d38e | 159 | putStrLn out |
5400d4bf | 160 | hFlush stdout |
2988d38e JM |
161 | repl_loop env |
162 | ||
163 | main = do | |
164 | args <- getArgs | |
165 | load_history | |
166 | ||
167 | repl_env <- env_new Nothing | |
168 | ||
169 | -- core.hs: defined using Haskell | |
170 | (mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns) | |
171 | env_set repl_env (MalSymbol "eval") (_func (\[ast] -> eval ast repl_env)) | |
c150ec41 | 172 | env_set repl_env (MalSymbol "*ARGV*") (MalList [] Nil) |
2988d38e JM |
173 | |
174 | -- core.mal: defined using the language itself | |
5400d4bf JM |
175 | runErrorT $ rep repl_env "(def! not (fn* (a) (if a false true)))" |
176 | runErrorT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" | |
2988d38e JM |
177 | |
178 | if length args > 0 then do | |
c150ec41 | 179 | env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)) Nil) |
5400d4bf | 180 | runErrorT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")" |
2988d38e JM |
181 | return () |
182 | else | |
183 | repl_loop repl_env |