Commit | Line | Data |
---|---|---|
5400d4bf | 1 | import System.IO (hFlush, stdout) |
2988d38e | 2 | import System.Environment (getArgs) |
5400d4bf | 3 | import Control.Monad (mapM) |
53db2d63 | 4 | import Control.Monad.Except (runExceptT) |
5400d4bf | 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 |
cffab551 DM |
63 | apply_ast ast@(MalList [] _) env = do |
64 | return ast | |
c150ec41 | 65 | apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do |
2988d38e JM |
66 | case args of |
67 | (a1@(MalSymbol _): a2 : []) -> do | |
68 | evaled <- eval a2 env | |
5400d4bf JM |
69 | liftIO $ env_set env a1 evaled |
70 | _ -> throwStr "invalid def!" | |
c150ec41 | 71 | apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do |
2988d38e | 72 | case args of |
c150ec41 JM |
73 | (a1 : a2 : []) -> do |
74 | params <- (_to_list a1) | |
5400d4bf | 75 | let_env <- liftIO $ env_new $ Just env |
c150ec41 | 76 | let_bind let_env params |
2988d38e | 77 | eval a2 let_env |
5400d4bf | 78 | _ -> throwStr "invalid let*" |
c150ec41 | 79 | apply_ast ast@(MalList (MalSymbol "quote" : args) _) env = do |
2988d38e JM |
80 | case args of |
81 | a1 : [] -> return a1 | |
5400d4bf | 82 | _ -> throwStr "invalid quote" |
c150ec41 | 83 | apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do |
2988d38e JM |
84 | case args of |
85 | a1 : [] -> eval (quasiquote a1) env | |
5400d4bf | 86 | _ -> throwStr "invalid quasiquote" |
c150ec41 | 87 | apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do |
2988d38e JM |
88 | case args of |
89 | ([]) -> return Nil | |
90 | _ -> do | |
c150ec41 | 91 | el <- eval_ast (MalList args Nil) env |
2988d38e | 92 | case el of |
c150ec41 | 93 | (MalList lst _) -> return $ last lst |
53db2d63 | 94 | |
c150ec41 | 95 | apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do |
2988d38e JM |
96 | case args of |
97 | (a1 : a2 : a3 : []) -> do | |
98 | cond <- eval a1 env | |
99 | if cond == MalFalse || cond == Nil | |
100 | then eval a3 env | |
101 | else eval a2 env | |
102 | (a1 : a2 : []) -> do | |
103 | cond <- eval a1 env | |
104 | if cond == MalFalse || cond == Nil | |
105 | then return Nil | |
106 | else eval a2 env | |
5400d4bf | 107 | _ -> throwStr "invalid if" |
c150ec41 JM |
108 | apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do |
109 | case args of | |
110 | (a1 : a2 : []) -> do | |
111 | params <- (_to_list a1) | |
112 | return $ (_malfunc a2 env (MalList params Nil) | |
113 | (\args -> do | |
5400d4bf JM |
114 | fn_env1 <- liftIO $ env_new $ Just env |
115 | fn_env2 <- liftIO $ env_bind fn_env1 params args | |
c150ec41 | 116 | eval a2 fn_env2)) |
5400d4bf | 117 | _ -> throwStr "invalid fn*" |
c150ec41 | 118 | apply_ast ast@(MalList _ _) env = do |
2988d38e JM |
119 | el <- eval_ast ast env |
120 | case el of | |
c150ec41 | 121 | (MalList ((Func (Fn f) _) : rest) _) -> |
2988d38e | 122 | f $ rest |
c150ec41 | 123 | (MalList ((MalFunc {ast=ast, env=fn_env, params=(MalList params Nil)}) : rest) _) -> do |
5400d4bf JM |
124 | fn_env1 <- liftIO $ env_new $ Just fn_env |
125 | fn_env2 <- liftIO $ env_bind fn_env1 params rest | |
2988d38e JM |
126 | eval ast fn_env2 |
127 | el -> | |
5400d4bf | 128 | throwStr $ "invalid apply: " ++ (show el) |
2988d38e | 129 | |
5400d4bf | 130 | eval :: MalVal -> Env -> IOThrows MalVal |
2988d38e JM |
131 | eval ast env = do |
132 | case ast of | |
c150ec41 | 133 | (MalList _ _) -> apply_ast ast env |
2988d38e JM |
134 | _ -> eval_ast ast env |
135 | ||
136 | ||
137 | ||
138 | mal_print :: MalVal -> String | |
139 | mal_print exp = show exp | |
140 | ||
141 | -- repl | |
142 | ||
5400d4bf | 143 | rep :: Env -> String -> IOThrows String |
2988d38e JM |
144 | rep env line = do |
145 | ast <- mal_read line | |
146 | exp <- eval ast env | |
147 | return $ mal_print exp | |
148 | ||
149 | repl_loop :: Env -> IO () | |
150 | repl_loop env = do | |
151 | line <- readline "user> " | |
152 | case line of | |
153 | Nothing -> return () | |
154 | Just "" -> repl_loop env | |
155 | Just str -> do | |
53db2d63 | 156 | res <- runExceptT $ rep env str |
5400d4bf JM |
157 | out <- case res of |
158 | Left (StringError str) -> return $ "Error: " ++ str | |
159 | Left (MalValError mv) -> return $ "Error: " ++ (show mv) | |
160 | Right val -> return val | |
2988d38e | 161 | putStrLn out |
5400d4bf | 162 | hFlush stdout |
2988d38e JM |
163 | repl_loop env |
164 | ||
165 | main = do | |
166 | args <- getArgs | |
167 | load_history | |
168 | ||
169 | repl_env <- env_new Nothing | |
170 | ||
171 | -- core.hs: defined using Haskell | |
172 | (mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns) | |
173 | env_set repl_env (MalSymbol "eval") (_func (\[ast] -> eval ast repl_env)) | |
c150ec41 | 174 | env_set repl_env (MalSymbol "*ARGV*") (MalList [] Nil) |
2988d38e JM |
175 | |
176 | -- core.mal: defined using the language itself | |
53db2d63 P |
177 | runExceptT $ rep repl_env "(def! not (fn* (a) (if a false true)))" |
178 | runExceptT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" | |
2988d38e JM |
179 | |
180 | if length args > 0 then do | |
c150ec41 | 181 | env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)) Nil) |
53db2d63 | 182 | runExceptT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")" |
2988d38e | 183 | return () |
53db2d63 | 184 | else |
2988d38e | 185 | repl_loop repl_env |