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) | |
b76aa73b JM |
5 | import qualified Data.Map as Map |
6 | import qualified Data.Traversable as DT | |
7 | ||
fa9a9758 | 8 | import Readline (readline, load_history) |
b76aa73b JM |
9 | import Types |
10 | import Reader (read_str) | |
11 | import Printer (_pr_str) | |
12 | import Env (Env, env_new, env_get, env_set) | |
13 | ||
14 | -- read | |
5400d4bf | 15 | mal_read :: String -> IOThrows MalVal |
b76aa73b JM |
16 | mal_read str = read_str str |
17 | ||
18 | -- eval | |
5400d4bf | 19 | eval_ast :: MalVal -> Env -> IOThrows MalVal |
b76aa73b | 20 | eval_ast sym@(MalSymbol _) env = env_get env sym |
c150ec41 | 21 | eval_ast ast@(MalList lst m) env = do |
b76aa73b | 22 | new_lst <- mapM (\x -> (eval x env)) lst |
c150ec41 JM |
23 | return $ MalList new_lst m |
24 | eval_ast ast@(MalVector lst m) env = do | |
b76aa73b | 25 | new_lst <- mapM (\x -> (eval x env)) lst |
c150ec41 JM |
26 | return $ MalVector new_lst m |
27 | eval_ast ast@(MalHashMap lst m) env = do | |
b76aa73b | 28 | new_hm <- DT.mapM (\x -> (eval x env)) lst |
c150ec41 | 29 | return $ MalHashMap new_hm m |
b76aa73b JM |
30 | eval_ast ast env = return ast |
31 | ||
5400d4bf | 32 | let_bind :: Env -> [MalVal] -> IOThrows Env |
b76aa73b JM |
33 | let_bind env [] = return env |
34 | let_bind env (b:e:xs) = do | |
35 | evaled <- eval e env | |
5400d4bf | 36 | x <- liftIO $ env_set env b evaled |
b76aa73b JM |
37 | let_bind env xs |
38 | ||
5400d4bf | 39 | apply_ast :: MalVal -> Env -> IOThrows MalVal |
c150ec41 | 40 | apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do |
b76aa73b JM |
41 | case args of |
42 | (a1@(MalSymbol _): a2 : []) -> do | |
43 | evaled <- eval a2 env | |
5400d4bf JM |
44 | liftIO $ env_set env a1 evaled |
45 | _ -> throwStr "invalid def!" | |
c150ec41 | 46 | apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do |
b76aa73b | 47 | case args of |
c150ec41 JM |
48 | (a1 : a2 : []) -> do |
49 | params <- (_to_list a1) | |
5400d4bf | 50 | let_env <- liftIO $ env_new $ Just env |
c150ec41 | 51 | let_bind let_env params |
b76aa73b | 52 | eval a2 let_env |
5400d4bf | 53 | _ -> throwStr "invalid let*" |
c150ec41 | 54 | apply_ast ast@(MalList _ _) env = do |
b76aa73b JM |
55 | el <- eval_ast ast env |
56 | case el of | |
c150ec41 | 57 | (MalList ((Func (Fn f) _) : rest) _) -> |
fa9a9758 | 58 | f $ rest |
b76aa73b | 59 | el -> |
5400d4bf | 60 | throwStr $ "invalid apply: " ++ (show el) |
b76aa73b | 61 | |
5400d4bf | 62 | eval :: MalVal -> Env -> IOThrows MalVal |
b76aa73b JM |
63 | eval ast env = do |
64 | case ast of | |
c150ec41 | 65 | (MalList _ _) -> apply_ast ast env |
b76aa73b JM |
66 | _ -> eval_ast ast env |
67 | ||
68 | ||
69 | ||
70 | mal_print :: MalVal -> String | |
71 | mal_print exp = show exp | |
72 | ||
73 | -- repl | |
c150ec41 | 74 | add [MalNumber a, MalNumber b] = return $ MalNumber $ a + b |
5400d4bf | 75 | add _ = throwStr $ "illegal arguments to +" |
c150ec41 | 76 | sub [MalNumber a, MalNumber b] = return $ MalNumber $ a - b |
5400d4bf | 77 | sub _ = throwStr $ "illegal arguments to -" |
c150ec41 | 78 | mult [MalNumber a, MalNumber b] = return $ MalNumber $ a * b |
5400d4bf | 79 | mult _ = throwStr $ "illegal arguments to *" |
c150ec41 | 80 | divd [MalNumber a, MalNumber b] = return $ MalNumber $ a `div` b |
5400d4bf | 81 | divd _ = throwStr $ "illegal arguments to /" |
b76aa73b | 82 | |
5400d4bf | 83 | rep :: Env -> String -> IOThrows String |
b76aa73b JM |
84 | rep env line = do |
85 | ast <- mal_read line | |
86 | exp <- eval ast env | |
87 | return $ mal_print exp | |
88 | ||
89 | repl_loop :: Env -> IO () | |
90 | repl_loop env = do | |
fa9a9758 JM |
91 | line <- readline "user> " |
92 | case line of | |
93 | Nothing -> return () | |
94 | Just "" -> repl_loop env | |
95 | Just str -> do | |
5400d4bf JM |
96 | res <- runErrorT $ rep env str |
97 | out <- case res of | |
98 | Left (StringError str) -> return $ "Error: " ++ str | |
99 | Left (MalValError mv) -> return $ "Error: " ++ (show mv) | |
100 | Right val -> return val | |
fa9a9758 | 101 | putStrLn out |
5400d4bf | 102 | hFlush stdout |
fa9a9758 | 103 | repl_loop env |
b76aa73b JM |
104 | |
105 | main = do | |
fa9a9758 | 106 | load_history |
c150ec41 | 107 | |
b76aa73b | 108 | repl_env <- env_new Nothing |
fa9a9758 JM |
109 | env_set repl_env (MalSymbol "+") $ _func add |
110 | env_set repl_env (MalSymbol "-") $ _func sub | |
111 | env_set repl_env (MalSymbol "*") $ _func mult | |
112 | env_set repl_env (MalSymbol "/") $ _func divd | |
b76aa73b | 113 | repl_loop repl_env |