Commit | Line | Data |
---|---|---|
5400d4bf JM |
1 | import System.IO (hFlush, stdout) |
2 | import Control.Monad (mapM) | |
53db2d63 | 3 | import Control.Monad.Except (runExceptT) |
5400d4bf | 4 | import Control.Monad.Trans (liftIO) |
fa9a9758 JM |
5 | import qualified Data.Map as Map |
6 | import qualified Data.Traversable as DT | |
7 | ||
8 | import Readline (readline, load_history) | |
9 | import Types | |
10 | import Reader (read_str) | |
11 | import Printer (_pr_str) | |
12 | import Env (Env, env_new, env_bind, env_get, env_set) | |
13 | import Core as Core | |
14 | ||
15 | -- read | |
5400d4bf | 16 | mal_read :: String -> IOThrows MalVal |
fa9a9758 JM |
17 | mal_read str = read_str str |
18 | ||
19 | -- eval | |
5400d4bf | 20 | eval_ast :: MalVal -> Env -> IOThrows MalVal |
fa9a9758 | 21 | eval_ast sym@(MalSymbol _) env = env_get env sym |
c150ec41 | 22 | eval_ast ast@(MalList lst m) env = do |
fa9a9758 | 23 | new_lst <- mapM (\x -> (eval x env)) lst |
c150ec41 JM |
24 | return $ MalList new_lst m |
25 | eval_ast ast@(MalVector lst m) env = do | |
fa9a9758 | 26 | new_lst <- mapM (\x -> (eval x env)) lst |
c150ec41 JM |
27 | return $ MalVector new_lst m |
28 | eval_ast ast@(MalHashMap lst m) env = do | |
fa9a9758 | 29 | new_hm <- DT.mapM (\x -> (eval x env)) lst |
c150ec41 | 30 | return $ MalHashMap new_hm m |
fa9a9758 JM |
31 | eval_ast ast env = return ast |
32 | ||
5400d4bf | 33 | let_bind :: Env -> [MalVal] -> IOThrows Env |
fa9a9758 JM |
34 | let_bind env [] = return env |
35 | let_bind env (b:e:xs) = do | |
36 | evaled <- eval e env | |
5400d4bf | 37 | x <- liftIO $ env_set env b evaled |
fa9a9758 JM |
38 | let_bind env xs |
39 | ||
5400d4bf | 40 | apply_ast :: MalVal -> Env -> IOThrows MalVal |
cffab551 DM |
41 | apply_ast ast@(MalList [] _) env = do |
42 | return ast | |
c150ec41 | 43 | apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do |
fa9a9758 JM |
44 | case args of |
45 | (a1@(MalSymbol _): a2 : []) -> do | |
46 | evaled <- eval a2 env | |
5400d4bf JM |
47 | liftIO $ env_set env a1 evaled |
48 | _ -> throwStr "invalid def!" | |
c150ec41 | 49 | apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do |
fa9a9758 | 50 | case args of |
c150ec41 JM |
51 | (a1 : a2 : []) -> do |
52 | params <- (_to_list a1) | |
5400d4bf | 53 | let_env <- liftIO $ env_new $ Just env |
c150ec41 | 54 | let_bind let_env params |
fa9a9758 | 55 | eval a2 let_env |
5400d4bf | 56 | _ -> throwStr "invalid let*" |
c150ec41 | 57 | apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do |
fa9a9758 JM |
58 | case args of |
59 | ([]) -> return Nil | |
60 | _ -> do | |
c150ec41 | 61 | el <- eval_ast (MalList args Nil) env |
fa9a9758 | 62 | case el of |
c150ec41 | 63 | (MalList lst _) -> return $ last lst |
53db2d63 | 64 | |
c150ec41 | 65 | apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do |
fa9a9758 JM |
66 | case args of |
67 | (a1 : a2 : a3 : []) -> do | |
68 | cond <- eval a1 env | |
69 | if cond == MalFalse || cond == Nil | |
70 | then eval a3 env | |
71 | else eval a2 env | |
72 | (a1 : a2 : []) -> do | |
73 | cond <- eval a1 env | |
74 | if cond == MalFalse || cond == Nil | |
75 | then return Nil | |
76 | else eval a2 env | |
5400d4bf | 77 | _ -> throwStr "invalid if" |
c150ec41 | 78 | apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do |
fa9a9758 | 79 | case args of |
c150ec41 JM |
80 | (a1 : a2 : []) -> do |
81 | params <- (_to_list a1) | |
82 | return $ (_func | |
83 | (\args -> do | |
5400d4bf JM |
84 | fn_env1 <- liftIO $ env_new $ Just env |
85 | fn_env2 <- liftIO $ env_bind fn_env1 params args | |
c150ec41 | 86 | eval a2 fn_env2)) |
5400d4bf | 87 | _ -> throwStr "invalid fn*" |
c150ec41 | 88 | apply_ast ast@(MalList _ _) env = do |
fa9a9758 JM |
89 | el <- eval_ast ast env |
90 | case el of | |
c150ec41 | 91 | (MalList ((Func (Fn f) _) : rest) _) -> |
fa9a9758 JM |
92 | f $ rest |
93 | el -> | |
5400d4bf | 94 | throwStr $ "invalid apply: " ++ (show el) |
fa9a9758 | 95 | |
5400d4bf | 96 | eval :: MalVal -> Env -> IOThrows MalVal |
fa9a9758 JM |
97 | eval ast env = do |
98 | case ast of | |
c150ec41 | 99 | (MalList _ _) -> apply_ast ast env |
fa9a9758 JM |
100 | _ -> eval_ast ast env |
101 | ||
102 | ||
103 | ||
104 | mal_print :: MalVal -> String | |
105 | mal_print exp = show exp | |
106 | ||
107 | -- repl | |
108 | ||
5400d4bf | 109 | rep :: Env -> String -> IOThrows String |
fa9a9758 JM |
110 | rep env line = do |
111 | ast <- mal_read line | |
112 | exp <- eval ast env | |
113 | return $ mal_print exp | |
114 | ||
115 | repl_loop :: Env -> IO () | |
116 | repl_loop env = do | |
117 | line <- readline "user> " | |
118 | case line of | |
119 | Nothing -> return () | |
120 | Just "" -> repl_loop env | |
121 | Just str -> do | |
53db2d63 | 122 | res <- runExceptT $ rep env str |
5400d4bf JM |
123 | out <- case res of |
124 | Left (StringError str) -> return $ "Error: " ++ str | |
125 | Left (MalValError mv) -> return $ "Error: " ++ (show mv) | |
126 | Right val -> return val | |
fa9a9758 | 127 | putStrLn out |
5400d4bf | 128 | hFlush stdout |
fa9a9758 JM |
129 | repl_loop env |
130 | ||
131 | main = do | |
132 | load_history | |
133 | ||
134 | repl_env <- env_new Nothing | |
135 | ||
136 | -- core.hs: defined using Haskell | |
137 | (mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns) | |
138 | ||
139 | -- core.mal: defined using the language itself | |
53db2d63 | 140 | runExceptT $ rep repl_env "(def! not (fn* (a) (if a false true)))" |
fa9a9758 JM |
141 | |
142 | repl_loop repl_env |