Commit | Line | Data |
---|---|---|
fa9a9758 JM |
1 | module Core |
2 | ( ns ) | |
3 | where | |
4 | ||
5400d4bf | 5 | import System.IO (hFlush, stdout) |
c150ec41 | 6 | import Control.Exception (catch) |
5400d4bf | 7 | import Control.Monad.Trans (liftIO) |
fa9a9758 | 8 | import qualified Data.Map as Map |
c150ec41 JM |
9 | import Data.Time.Clock.POSIX (getPOSIXTime) |
10 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) | |
fa9a9758 | 11 | |
c150ec41 | 12 | import Readline (readline) |
fa9a9758 JM |
13 | import Reader (read_str) |
14 | import Types | |
15 | import Printer (_pr_str, _pr_list) | |
16 | ||
17 | -- General functions | |
18 | ||
c150ec41 | 19 | equal_Q [a, b] = return $ if a == b then MalTrue else MalFalse |
5400d4bf | 20 | equal_Q _ = throwStr "illegal arguments to =" |
fa9a9758 | 21 | |
5400d4bf | 22 | run_1 :: (MalVal -> MalVal) -> [MalVal] -> IOThrows MalVal |
c150ec41 | 23 | run_1 f (x:[]) = return $ f x |
5400d4bf | 24 | run_1 _ _ = throwStr "function takes a single argument" |
fa9a9758 | 25 | |
5400d4bf | 26 | run_2 :: (MalVal -> MalVal -> MalVal) -> [MalVal] -> IOThrows MalVal |
c150ec41 | 27 | run_2 f (x:y:[]) = return $ f x y |
5400d4bf JM |
28 | run_2 _ _ = throwStr "function takes a two arguments" |
29 | ||
30 | -- Error/Exception functions | |
31 | ||
32 | throw (mv:[]) = throwMalVal mv | |
33 | throw _ = throwStr "illegal arguments to throw" | |
c150ec41 JM |
34 | |
35 | -- Scalar functions | |
36 | ||
5400d4bf JM |
37 | symbol (MalString str:[]) = return $ MalSymbol str |
38 | symbol _ = throwStr "symbol called with non-string" | |
c150ec41 | 39 | |
dbac60df | 40 | keyword (MalString ('\x029e':str):[]) = return $ MalString $ "\x029e" ++ str |
5400d4bf JM |
41 | keyword (MalString str:[]) = return $ MalString $ "\x029e" ++ str |
42 | keyword _ = throwStr "keyword called with non-string" | |
2988d38e | 43 | |
fa9a9758 JM |
44 | |
45 | -- String functions | |
46 | ||
47 | pr_str args = do | |
48 | return $ MalString $ _pr_list True " " args | |
49 | ||
50 | str args = do | |
51 | return $ MalString $ _pr_list False "" args | |
52 | ||
53 | prn args = do | |
5400d4bf JM |
54 | liftIO $ putStrLn $ _pr_list True " " args |
55 | liftIO $ hFlush stdout | |
fa9a9758 JM |
56 | return Nil |
57 | ||
58 | println args = do | |
5400d4bf JM |
59 | liftIO $ putStrLn $ _pr_list False " " args |
60 | liftIO $ hFlush stdout | |
fa9a9758 JM |
61 | return Nil |
62 | ||
c150ec41 | 63 | slurp ([MalString path]) = do |
5400d4bf | 64 | str <- liftIO $ readFile path |
c150ec41 | 65 | return $ MalString str |
5400d4bf | 66 | slurp _ = throwStr "invalid arguments to slurp" |
c150ec41 JM |
67 | |
68 | do_readline ([MalString prompt]) = do | |
5400d4bf | 69 | str <- liftIO $ readline prompt |
c150ec41 | 70 | case str of |
5400d4bf | 71 | Nothing -> throwStr "readline failed" |
c150ec41 | 72 | Just str -> return $ MalString str |
5400d4bf | 73 | do_readline _ = throwStr "invalid arguments to readline" |
fa9a9758 JM |
74 | |
75 | -- Numeric functions | |
76 | ||
c150ec41 JM |
77 | num_op op [MalNumber a, MalNumber b] = do |
78 | return $ MalNumber $ op a b | |
5400d4bf | 79 | num_op _ _ = throwStr "illegal arguments to number operation" |
c150ec41 JM |
80 | |
81 | cmp_op op [MalNumber a, MalNumber b] = do | |
82 | return $ if op a b then MalTrue else MalFalse | |
5400d4bf | 83 | cmp_op _ _ = throwStr "illegal arguments to comparison operation" |
fa9a9758 | 84 | |
c150ec41 | 85 | time_ms _ = do |
5400d4bf | 86 | t <- liftIO $ getPOSIXTime |
c150ec41 | 87 | return $ MalNumber $ round (t * 1000) |
fa9a9758 JM |
88 | |
89 | ||
90 | -- List functions | |
91 | ||
c150ec41 | 92 | list args = return $ MalList args Nil |
fa9a9758 JM |
93 | |
94 | -- Vector functions | |
95 | ||
c150ec41 | 96 | vector args = return $ MalVector args Nil |
fa9a9758 JM |
97 | |
98 | -- Hash Map functions | |
99 | ||
5400d4bf | 100 | _pairup [x] = throwStr "Odd number of elements to _pairup" |
c150ec41 JM |
101 | _pairup [] = return [] |
102 | _pairup (MalString x:y:xs) = do | |
103 | rest <- _pairup xs | |
104 | return $ (x,y):rest | |
105 | ||
fa9a9758 | 106 | hash_map args = do |
c150ec41 JM |
107 | pairs <- _pairup args |
108 | return $ MalHashMap (Map.fromList pairs) Nil | |
109 | ||
110 | assoc (MalHashMap hm _:kvs) = do | |
111 | pairs <- _pairup kvs | |
112 | return $ MalHashMap (Map.union (Map.fromList pairs) hm) Nil | |
5400d4bf | 113 | assoc _ = throwStr "invalid call to assoc" |
c150ec41 JM |
114 | |
115 | dissoc (MalHashMap hm _:ks) = do | |
116 | let remover = (\hm (MalString k) -> Map.delete k hm) in | |
117 | return $ MalHashMap (foldl remover hm ks) Nil | |
5400d4bf | 118 | dissoc _ = throwStr "invalid call to dissoc" |
c150ec41 JM |
119 | |
120 | get (MalHashMap hm _:MalString k:[]) = do | |
121 | case Map.lookup k hm of | |
122 | Just mv -> return mv | |
123 | Nothing -> return Nil | |
124 | get (Nil:MalString k:[]) = return Nil | |
5400d4bf | 125 | get _ = throwStr "invalid call to get" |
c150ec41 JM |
126 | |
127 | contains_Q (MalHashMap hm _:MalString k:[]) = do | |
128 | if Map.member k hm then return MalTrue | |
129 | else return MalFalse | |
130 | contains_Q (Nil:MalString k:[]) = return MalFalse | |
5400d4bf | 131 | contains_Q _ = throwStr "invalid call to contains?" |
c150ec41 JM |
132 | |
133 | keys (MalHashMap hm _:[]) = do | |
134 | return $ MalList (map MalString (Map.keys hm)) Nil | |
5400d4bf | 135 | keys _ = throwStr "invalid call to keys" |
c150ec41 JM |
136 | |
137 | vals (MalHashMap hm _:[]) = do | |
138 | return $ MalList (Map.elems hm) Nil | |
5400d4bf | 139 | vals _ = throwStr "invalid call to vals" |
c150ec41 | 140 | |
fa9a9758 JM |
141 | |
142 | -- Sequence functions | |
143 | ||
c150ec41 JM |
144 | _sequential_Q (MalList _ _) = MalTrue |
145 | _sequential_Q (MalVector _ _) = MalTrue | |
146 | _sequential_Q _ = MalFalse | |
147 | ||
148 | cons x Nil = MalList [x] Nil | |
149 | cons x (MalList lst _) = MalList (x:lst) Nil | |
150 | cons x (MalVector lst _) = MalList (x:lst) Nil | |
151 | ||
152 | concat1 a (MalList lst _) = a ++ lst | |
153 | concat1 a (MalVector lst _) = a ++ lst | |
154 | do_concat args = return $ MalList (foldl concat1 [] args) Nil | |
155 | ||
156 | nth ((MalList lst _):(MalNumber idx):[]) = do | |
157 | if idx < length lst then return $ lst !! idx | |
5400d4bf | 158 | else throwStr "nth: index out of range" |
c150ec41 JM |
159 | nth ((MalVector lst _):(MalNumber idx):[]) = do |
160 | if idx < length lst then return $ lst !! idx | |
5400d4bf JM |
161 | else throwStr "nth: index out of range" |
162 | nth _ = throwStr "invalid call to nth" | |
c150ec41 | 163 | |
6832696b | 164 | first Nil = Nil |
c150ec41 JM |
165 | first (MalList lst _) = if length lst > 0 then lst !! 0 else Nil |
166 | first (MalVector lst _) = if length lst > 0 then lst !! 0 else Nil | |
167 | ||
6832696b | 168 | rest Nil = MalList [] Nil |
c150ec41 JM |
169 | rest (MalList lst _) = MalList (drop 1 lst) Nil |
170 | rest (MalVector lst _) = MalList (drop 1 lst) Nil | |
171 | ||
172 | empty_Q Nil = MalTrue | |
173 | empty_Q (MalList [] _) = MalTrue | |
174 | empty_Q (MalVector [] _) = MalTrue | |
175 | empty_Q _ = MalFalse | |
176 | ||
5400d4bf JM |
177 | count (Nil:[]) = return $ MalNumber 0 |
178 | count (MalList lst _:[]) = return $ MalNumber $ length lst | |
179 | count (MalVector lst _:[]) = return $ MalNumber $ length lst | |
180 | count _ = throwStr $ "non-sequence passed to count" | |
fa9a9758 | 181 | |
c150ec41 JM |
182 | apply args = do |
183 | f <- _get_call args | |
184 | lst <- _to_list (last args) | |
185 | f $ (init (drop 1 args)) ++ lst | |
186 | ||
187 | do_map args = do | |
188 | f <- _get_call args | |
189 | lst <- _to_list (args !! 1) | |
190 | do new_lst <- mapM (\x -> f [x]) lst | |
191 | return $ MalList new_lst Nil | |
192 | ||
defa41f3 JM |
193 | conj ((MalList lst _):args) = return $ MalList ((reverse args) ++ lst) Nil |
194 | conj ((MalVector lst _):args) = return $ MalVector (lst ++ args) Nil | |
195 | conj _ = throwStr $ "illegal arguments to conj" | |
196 | ||
197 | do_seq (l@(MalList [] _):[]) = return $ Nil | |
198 | do_seq (l@(MalList lst m):[]) = return $ l | |
199 | do_seq (MalVector [] _:[]) = return $ Nil | |
200 | do_seq (MalVector lst _:[]) = return $ MalList lst Nil | |
201 | do_seq (MalString []:[]) = return $ Nil | |
202 | do_seq (MalString s:[]) = return $ MalList [MalString [c] | c <- s] Nil | |
203 | do_seq (Nil:[]) = return $ Nil | |
204 | do_seq _ = throwStr $ "seq: called on non-sequence" | |
205 | ||
c150ec41 JM |
206 | -- Metadata functions |
207 | ||
208 | with_meta ((MalList lst _):m:[]) = return $ MalList lst m | |
209 | with_meta ((MalVector lst _):m:[]) = return $ MalVector lst m | |
210 | with_meta ((MalHashMap hm _):m:[]) = return $ MalHashMap hm m | |
211 | with_meta ((MalAtom atm _):m:[]) = return $ MalAtom atm m | |
212 | with_meta ((Func f _):m:[]) = return $ Func f m | |
213 | with_meta ((MalFunc {fn=f, ast=a, env=e, params=p, macro=mc}):m:[]) = do | |
214 | return $ MalFunc {fn=f, ast=a, env=e, params=p, macro=mc, meta=m} | |
5400d4bf | 215 | with_meta _ = throwStr $ "invalid with-meta call" |
c150ec41 JM |
216 | |
217 | do_meta ((MalList _ m):[]) = return m | |
218 | do_meta ((MalVector _ m):[]) = return m | |
219 | do_meta ((MalHashMap _ m):[]) = return m | |
220 | do_meta ((MalAtom _ m):[]) = return m | |
221 | do_meta ((Func _ m):[]) = return m | |
222 | do_meta ((MalFunc {meta=m}):[]) = return m | |
5400d4bf | 223 | do_meta _ = throwStr $ "invalid meta call" |
c150ec41 JM |
224 | |
225 | -- Atom functions | |
226 | ||
227 | atom (val:[]) = do | |
5400d4bf | 228 | ref <- liftIO $ newIORef val |
c150ec41 | 229 | return $ MalAtom ref Nil |
5400d4bf | 230 | atom _ = throwStr "invalid atom call" |
c150ec41 JM |
231 | |
232 | deref (MalAtom ref _:[]) = do | |
5400d4bf | 233 | val <- liftIO $ readIORef ref |
c150ec41 | 234 | return val |
5400d4bf | 235 | deref _ = throwStr "invalid deref call" |
c150ec41 JM |
236 | |
237 | reset_BANG (MalAtom ref _:val:[]) = do | |
5400d4bf | 238 | liftIO $ writeIORef ref $ val |
c150ec41 | 239 | return val |
5400d4bf | 240 | reset_BANG _ = throwStr "invalid deref call" |
c150ec41 JM |
241 | |
242 | swap_BANG (MalAtom ref _:args) = do | |
5400d4bf | 243 | val <- liftIO $ readIORef ref |
c150ec41 JM |
244 | f <- _get_call args |
245 | new_val <- f $ [val] ++ (tail args) | |
5400d4bf | 246 | _ <- liftIO $ writeIORef ref $ new_val |
c150ec41 | 247 | return new_val |
fa9a9758 JM |
248 | |
249 | ns = [ | |
250 | ("=", _func equal_Q), | |
5400d4bf | 251 | ("throw", _func throw), |
c150ec41 JM |
252 | ("nil?", _func $ run_1 $ _nil_Q), |
253 | ("true?", _func $ run_1 $ _true_Q), | |
254 | ("false?", _func $ run_1 $ _false_Q), | |
defa41f3 | 255 | ("string?", _func $ run_1 $ _string_Q), |
5400d4bf | 256 | ("symbol", _func $ symbol), |
c150ec41 | 257 | ("symbol?", _func $ run_1 $ _symbol_Q), |
5400d4bf | 258 | ("keyword", _func $ keyword), |
c150ec41 | 259 | ("keyword?", _func $ run_1 $ _keyword_Q), |
3d1dbb20 JM |
260 | ("number?", _func $ run_1 $ _number_Q), |
261 | ("fn?", _func $ run_1 $ _fn_Q), | |
262 | ("macro?", _func $ run_1 $ _macro_Q), | |
fa9a9758 JM |
263 | |
264 | ("pr-str", _func pr_str), | |
265 | ("str", _func str), | |
266 | ("prn", _func prn), | |
267 | ("println", _func println), | |
c150ec41 | 268 | ("readline", _func do_readline), |
fa9a9758 JM |
269 | ("read-string", _func (\[(MalString s)] -> read_str s)), |
270 | ("slurp", _func slurp), | |
c150ec41 | 271 | |
fa9a9758 JM |
272 | ("<", _func $ cmp_op (<)), |
273 | ("<=", _func $ cmp_op (<=)), | |
274 | (">", _func $ cmp_op (>)), | |
275 | (">=", _func $ cmp_op (>=)), | |
276 | ("+", _func $ num_op (+)), | |
277 | ("-", _func $ num_op (-)), | |
278 | ("*", _func $ num_op (*)), | |
279 | ("/", _func $ num_op (div)), | |
c150ec41 | 280 | ("time-ms", _func $ time_ms), |
53db2d63 | 281 | |
fa9a9758 JM |
282 | ("list", _func $ list), |
283 | ("list?", _func $ run_1 _list_Q), | |
284 | ("vector", _func $ vector), | |
c150ec41 | 285 | ("vector?", _func $ run_1 _vector_Q), |
fa9a9758 | 286 | ("hash-map", _func $ hash_map), |
c150ec41 JM |
287 | ("map?", _func $ run_1 _hash_map_Q), |
288 | ("assoc", _func $ assoc), | |
289 | ("dissoc", _func $ dissoc), | |
290 | ("get", _func $ get), | |
291 | ("contains?",_func $ contains_Q), | |
292 | ("keys", _func $ keys), | |
293 | ("vals", _func $ vals), | |
294 | ||
295 | ("sequential?", _func $ run_1 _sequential_Q), | |
2988d38e JM |
296 | ("cons", _func $ run_2 $ cons), |
297 | ("concat", _func $ do_concat), | |
298 | ("nth", _func nth), | |
299 | ("first", _func $ run_1 $ first), | |
300 | ("rest", _func $ run_1 $ rest), | |
c150ec41 | 301 | ("empty?", _func $ run_1 $ empty_Q), |
5400d4bf | 302 | ("count", _func $ count), |
c150ec41 JM |
303 | ("apply", _func $ apply), |
304 | ("map", _func $ do_map), | |
305 | ||
defa41f3 JM |
306 | ("conj", _func $ conj), |
307 | ("seq", _func $ do_seq), | |
308 | ||
c150ec41 JM |
309 | ("with-meta", _func $ with_meta), |
310 | ("meta", _func $ do_meta), | |
311 | ("atom", _func $ atom), | |
312 | ("atom?", _func $ run_1 _atom_Q), | |
313 | ("deref", _func $ deref), | |
314 | ("reset!", _func $ reset_BANG), | |
315 | ("swap!", _func $ swap_BANG)] |