Commit | Line | Data |
---|---|---|
5400d4bf | 1 | import System.IO (hFlush, stdout) |
87cb47ec | 2 | import Control.Monad ((<=<)) |
53db2d63 | 3 | import Control.Monad.Except (runExceptT) |
5400d4bf | 4 | import Control.Monad.Trans (liftIO) |
6116c2d5 | 5 | import Data.Foldable (foldlM) |
fa9a9758 | 6 | |
219f15b7 | 7 | import Readline (addHistory, readline, load_history) |
fa9a9758 JM |
8 | import Types |
9 | import Reader (read_str) | |
10 | import Printer (_pr_str) | |
52371c3e | 11 | import Env (env_new, env_bind, env_get, env_set) |
6116c2d5 | 12 | import Core (ns) |
fa9a9758 JM |
13 | |
14 | -- read | |
6116c2d5 | 15 | |
5400d4bf | 16 | mal_read :: String -> IOThrows MalVal |
6116c2d5 | 17 | mal_read = read_str |
fa9a9758 JM |
18 | |
19 | -- eval | |
fa9a9758 | 20 | |
6116c2d5 | 21 | -- eval_ast is replaced with pattern matching. |
fa9a9758 | 22 | |
6116c2d5 NB |
23 | let_bind :: Env -> [MalVal] -> IOThrows () |
24 | let_bind _ [] = return () | |
25 | let_bind env (MalSymbol b : e : xs) = do | |
26 | liftIO . env_set env b =<< eval env e | |
27 | let_bind env xs | |
28 | let_bind _ _ = throwStr "invalid let*" | |
29 | ||
30 | unWrapSymbol :: MalVal -> IOThrows String | |
31 | unWrapSymbol (MalSymbol s) = return s | |
32 | unWrapSymbol _ = throwStr "fn* parameter must be symbols" | |
33 | ||
34 | newFunction :: MalVal -> Env -> [String] -> MalVal | |
35 | newFunction a env p = MalFunction {f_ast=a, f_params=p, macro=False, meta=Nil, | |
36 | fn=(\args -> do | |
37 | fn_env <- liftIO $ env_new env | |
38 | ok <- liftIO $ env_bind fn_env p args | |
39 | case ok of | |
40 | True -> eval fn_env a | |
41 | False -> throwStr $ "actual parameters do not match signature " ++ show p)} | |
42 | ||
43 | apply_ast :: [MalVal] -> Env -> IOThrows MalVal | |
44 | ||
45 | apply_ast [] _ = return $ toList [] | |
46 | ||
47 | apply_ast [MalSymbol "def!", MalSymbol a1, a2] env = do | |
48 | evd <- eval env a2 | |
49 | liftIO $ env_set env a1 evd | |
50 | return evd | |
51 | apply_ast (MalSymbol "def!" : _) _ = throwStr "invalid def!" | |
52 | ||
53 | apply_ast [MalSymbol "let*", MalSeq _ _ params, a2] env = do | |
54 | let_env <- liftIO $ env_new env | |
55 | let_bind let_env params | |
56 | eval let_env a2 | |
57 | apply_ast (MalSymbol "let*" : _) _ = throwStr "invalid let*" | |
58 | ||
59 | apply_ast (MalSymbol "do" : args) env = foldlM (const $ eval env) Nil args | |
60 | ||
61 | apply_ast [MalSymbol "if", a1, a2, a3] env = do | |
62 | cond <- eval env a1 | |
63 | eval env $ case cond of | |
64 | Nil -> a3 | |
65 | MalBoolean False -> a3 | |
66 | _ -> a2 | |
67 | apply_ast [MalSymbol "if", a1, a2] env = do | |
68 | cond <- eval env a1 | |
69 | case cond of | |
70 | Nil -> return Nil | |
71 | MalBoolean False -> return Nil | |
72 | _ -> eval env a2 | |
73 | apply_ast (MalSymbol "if" : _) _ = throwStr "invalid if" | |
74 | ||
75 | apply_ast [MalSymbol "fn*", MalSeq _ _ params, ast] env = newFunction ast env <$> mapM unWrapSymbol params | |
76 | apply_ast (MalSymbol "fn*" : _) _ = throwStr "invalid fn*" | |
77 | ||
78 | apply_ast ast env = do | |
79 | evd <- mapM (eval env) ast | |
80 | case evd of | |
81 | MalFunction {fn=f} : args -> f args | |
87cb47ec | 82 | _ -> throwStr . (++) "invalid apply: " =<< liftIO (Printer._pr_str True (toList ast)) |
6116c2d5 NB |
83 | |
84 | eval :: Env -> MalVal -> IOThrows MalVal | |
85 | eval env (MalSymbol sym) = do | |
86 | maybeVal <- liftIO $ env_get env sym | |
87 | case maybeVal of | |
88 | Nothing -> throwStr $ "'" ++ sym ++ "' not found" | |
89 | Just val -> return val | |
90 | eval env (MalSeq _ (Vect False) xs) = apply_ast xs env | |
91 | eval env (MalSeq m (Vect True) xs) = MalSeq m (Vect True) <$> mapM (eval env) xs | |
92 | eval env (MalHashMap m xs) = MalHashMap m <$> mapM (eval env) xs | |
93 | eval _ ast = return ast | |
fa9a9758 JM |
94 | |
95 | ||
6116c2d5 | 96 | |
87cb47ec NB |
97 | mal_print :: MalVal -> IOThrows String |
98 | mal_print = liftIO. Printer._pr_str True | |
fa9a9758 JM |
99 | |
100 | -- repl | |
101 | ||
5400d4bf | 102 | rep :: Env -> String -> IOThrows String |
87cb47ec | 103 | rep env = mal_print <=< eval env <=< mal_read |
fa9a9758 JM |
104 | |
105 | repl_loop :: Env -> IO () | |
106 | repl_loop env = do | |
107 | line <- readline "user> " | |
108 | case line of | |
109 | Nothing -> return () | |
110 | Just "" -> repl_loop env | |
111 | Just str -> do | |
219f15b7 | 112 | addHistory str |
53db2d63 | 113 | res <- runExceptT $ rep env str |
5400d4bf | 114 | out <- case res of |
87cb47ec | 115 | Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) |
5400d4bf | 116 | Right val -> return val |
fa9a9758 | 117 | putStrLn out |
5400d4bf | 118 | hFlush stdout |
fa9a9758 JM |
119 | repl_loop env |
120 | ||
6116c2d5 NB |
121 | -- Read and evaluate a line. Ignore successful results, but crash in |
122 | -- case of error. This is intended for the startup procedure. | |
123 | re :: Env -> String -> IO () | |
124 | re repl_env line = do | |
125 | res <- runExceptT $ eval repl_env =<< mal_read line | |
126 | case res of | |
87cb47ec | 127 | Left mv -> error . (++) "Startup failed: " <$> Printer._pr_str True mv |
6116c2d5 NB |
128 | Right _ -> return () |
129 | ||
130 | defBuiltIn :: Env -> (String, Fn) -> IO () | |
131 | defBuiltIn env (sym, f) = | |
132 | env_set env sym $ MalFunction {fn=f, f_ast=Nil, f_params=[], macro=False, meta=Nil} | |
133 | ||
134 | main :: IO () | |
fa9a9758 JM |
135 | main = do |
136 | load_history | |
137 | ||
6116c2d5 | 138 | repl_env <- env_new [] |
fa9a9758 JM |
139 | |
140 | -- core.hs: defined using Haskell | |
6116c2d5 | 141 | mapM_ (defBuiltIn repl_env) Core.ns |
fa9a9758 JM |
142 | |
143 | -- core.mal: defined using the language itself | |
6116c2d5 | 144 | re repl_env "(def! not (fn* (a) (if a false true)))" |
fa9a9758 JM |
145 | |
146 | repl_loop repl_env |