Commit | Line | Data |
---|---|---|
5400d4bf JM |
1 | import System.IO (hFlush, stdout) |
2 | import Control.Monad (mapM) | |
3 | import Control.Monad.Error (runErrorT) | |
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 |
c150ec41 | 41 | apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do |
fa9a9758 JM |
42 | case args of |
43 | (a1@(MalSymbol _): a2 : []) -> do | |
44 | evaled <- eval a2 env | |
5400d4bf JM |
45 | liftIO $ env_set env a1 evaled |
46 | _ -> throwStr "invalid def!" | |
c150ec41 | 47 | apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do |
fa9a9758 | 48 | case args of |
c150ec41 JM |
49 | (a1 : a2 : []) -> do |
50 | params <- (_to_list a1) | |
5400d4bf | 51 | let_env <- liftIO $ env_new $ Just env |
c150ec41 | 52 | let_bind let_env params |
fa9a9758 | 53 | eval a2 let_env |
5400d4bf | 54 | _ -> throwStr "invalid let*" |
c150ec41 | 55 | apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do |
fa9a9758 JM |
56 | case args of |
57 | ([]) -> return Nil | |
58 | _ -> do | |
c150ec41 | 59 | el <- eval_ast (MalList args Nil) env |
fa9a9758 | 60 | case el of |
c150ec41 | 61 | (MalList lst _) -> return $ last lst |
fa9a9758 | 62 | |
c150ec41 | 63 | apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do |
fa9a9758 JM |
64 | case args of |
65 | (a1 : a2 : a3 : []) -> do | |
66 | cond <- eval a1 env | |
67 | if cond == MalFalse || cond == Nil | |
68 | then eval a3 env | |
69 | else eval a2 env | |
70 | (a1 : a2 : []) -> do | |
71 | cond <- eval a1 env | |
72 | if cond == MalFalse || cond == Nil | |
73 | then return Nil | |
74 | else eval a2 env | |
5400d4bf | 75 | _ -> throwStr "invalid if" |
c150ec41 JM |
76 | apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do |
77 | case args of | |
78 | (a1 : a2 : []) -> do | |
79 | params <- (_to_list a1) | |
80 | return $ (_malfunc a2 env (MalList params Nil) | |
81 | (\args -> do | |
5400d4bf JM |
82 | fn_env1 <- liftIO $ env_new $ Just env |
83 | fn_env2 <- liftIO $ env_bind fn_env1 params args | |
c150ec41 | 84 | eval a2 fn_env2)) |
5400d4bf | 85 | _ -> throwStr "invalid fn*" |
c150ec41 | 86 | apply_ast ast@(MalList _ _) env = do |
fa9a9758 JM |
87 | el <- eval_ast ast env |
88 | case el of | |
c150ec41 | 89 | (MalList ((Func (Fn f) _) : rest) _) -> |
fa9a9758 | 90 | f $ rest |
c150ec41 | 91 | (MalList ((MalFunc {ast=ast, env=fn_env, params=(MalList params Nil)}) : rest) _) -> do |
5400d4bf JM |
92 | fn_env1 <- liftIO $ env_new $ Just fn_env |
93 | fn_env2 <- liftIO $ env_bind fn_env1 params rest | |
fa9a9758 JM |
94 | eval ast fn_env2 |
95 | el -> | |
5400d4bf | 96 | throwStr $ "invalid apply: " ++ (show el) |
fa9a9758 | 97 | |
5400d4bf | 98 | eval :: MalVal -> Env -> IOThrows MalVal |
fa9a9758 JM |
99 | eval ast env = do |
100 | case ast of | |
c150ec41 | 101 | (MalList _ _) -> apply_ast ast env |
fa9a9758 JM |
102 | _ -> eval_ast ast env |
103 | ||
104 | ||
105 | ||
106 | mal_print :: MalVal -> String | |
107 | mal_print exp = show exp | |
108 | ||
109 | -- repl | |
110 | ||
5400d4bf | 111 | rep :: Env -> String -> IOThrows String |
fa9a9758 JM |
112 | rep env line = do |
113 | ast <- mal_read line | |
114 | exp <- eval ast env | |
115 | return $ mal_print exp | |
116 | ||
117 | repl_loop :: Env -> IO () | |
118 | repl_loop env = do | |
119 | line <- readline "user> " | |
120 | case line of | |
121 | Nothing -> return () | |
122 | Just "" -> repl_loop env | |
123 | Just str -> do | |
5400d4bf JM |
124 | res <- runErrorT $ rep env str |
125 | out <- case res of | |
126 | Left (StringError str) -> return $ "Error: " ++ str | |
127 | Left (MalValError mv) -> return $ "Error: " ++ (show mv) | |
128 | Right val -> return val | |
fa9a9758 | 129 | putStrLn out |
5400d4bf | 130 | hFlush stdout |
fa9a9758 JM |
131 | repl_loop env |
132 | ||
133 | main = do | |
134 | load_history | |
135 | ||
136 | repl_env <- env_new Nothing | |
137 | ||
138 | -- core.hs: defined using Haskell | |
139 | (mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns) | |
140 | ||
141 | -- core.mal: defined using the language itself | |
5400d4bf | 142 | runErrorT $ rep repl_env "(def! not (fn* (a) (if a false true)))" |
fa9a9758 JM |
143 | |
144 | repl_loop repl_env |