mirror of
https://github.com/kanaka/mal.git
synced 2024-11-10 12:47:45 +03:00
298 lines
8.6 KiB
Haskell
298 lines
8.6 KiB
Haskell
module Core
|
|
( ns )
|
|
where
|
|
|
|
import System.IO (hFlush, stdout)
|
|
import Control.Exception (catch)
|
|
import Control.Monad.Trans (liftIO)
|
|
import qualified Data.Map as Map
|
|
import Data.Time.Clock.POSIX (getPOSIXTime)
|
|
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
|
|
|
import Readline (readline)
|
|
import Reader (read_str)
|
|
import Types
|
|
import Printer (_pr_str, _pr_list)
|
|
|
|
-- General functions
|
|
|
|
equal_Q [a, b] = return $ if a == b then MalTrue else MalFalse
|
|
equal_Q _ = throwStr "illegal arguments to ="
|
|
|
|
run_1 :: (MalVal -> MalVal) -> [MalVal] -> IOThrows MalVal
|
|
run_1 f (x:[]) = return $ f x
|
|
run_1 _ _ = throwStr "function takes a single argument"
|
|
|
|
run_2 :: (MalVal -> MalVal -> MalVal) -> [MalVal] -> IOThrows MalVal
|
|
run_2 f (x:y:[]) = return $ f x y
|
|
run_2 _ _ = throwStr "function takes a two arguments"
|
|
|
|
-- Error/Exception functions
|
|
|
|
throw (mv:[]) = throwMalVal mv
|
|
throw _ = throwStr "illegal arguments to throw"
|
|
|
|
-- Scalar functions
|
|
|
|
symbol (MalString str:[]) = return $ MalSymbol str
|
|
symbol _ = throwStr "symbol called with non-string"
|
|
|
|
keyword (MalString str:[]) = return $ MalString $ "\x029e" ++ str
|
|
keyword _ = throwStr "keyword called with non-string"
|
|
|
|
|
|
-- String functions
|
|
|
|
pr_str args = do
|
|
return $ MalString $ _pr_list True " " args
|
|
|
|
str args = do
|
|
return $ MalString $ _pr_list False "" args
|
|
|
|
prn args = do
|
|
liftIO $ putStrLn $ _pr_list True " " args
|
|
liftIO $ hFlush stdout
|
|
return Nil
|
|
|
|
println args = do
|
|
liftIO $ putStrLn $ _pr_list False " " args
|
|
liftIO $ hFlush stdout
|
|
return Nil
|
|
|
|
slurp ([MalString path]) = do
|
|
str <- liftIO $ readFile path
|
|
return $ MalString str
|
|
slurp _ = throwStr "invalid arguments to slurp"
|
|
|
|
do_readline ([MalString prompt]) = do
|
|
str <- liftIO $ readline prompt
|
|
case str of
|
|
Nothing -> throwStr "readline failed"
|
|
Just str -> return $ MalString str
|
|
do_readline _ = throwStr "invalid arguments to readline"
|
|
|
|
-- Numeric functions
|
|
|
|
num_op op [MalNumber a, MalNumber b] = do
|
|
return $ MalNumber $ op a b
|
|
num_op _ _ = throwStr "illegal arguments to number operation"
|
|
|
|
cmp_op op [MalNumber a, MalNumber b] = do
|
|
return $ if op a b then MalTrue else MalFalse
|
|
cmp_op _ _ = throwStr "illegal arguments to comparison operation"
|
|
|
|
time_ms _ = do
|
|
t <- liftIO $ getPOSIXTime
|
|
return $ MalNumber $ round (t * 1000)
|
|
|
|
|
|
-- List functions
|
|
|
|
list args = return $ MalList args Nil
|
|
|
|
-- Vector functions
|
|
|
|
vector args = return $ MalVector args Nil
|
|
|
|
-- Hash Map functions
|
|
|
|
_pairup [x] = throwStr "Odd number of elements to _pairup"
|
|
_pairup [] = return []
|
|
_pairup (MalString x:y:xs) = do
|
|
rest <- _pairup xs
|
|
return $ (x,y):rest
|
|
|
|
hash_map args = do
|
|
pairs <- _pairup args
|
|
return $ MalHashMap (Map.fromList pairs) Nil
|
|
|
|
assoc (MalHashMap hm _:kvs) = do
|
|
pairs <- _pairup kvs
|
|
return $ MalHashMap (Map.union (Map.fromList pairs) hm) Nil
|
|
assoc _ = throwStr "invalid call to assoc"
|
|
|
|
dissoc (MalHashMap hm _:ks) = do
|
|
let remover = (\hm (MalString k) -> Map.delete k hm) in
|
|
return $ MalHashMap (foldl remover hm ks) Nil
|
|
dissoc _ = throwStr "invalid call to dissoc"
|
|
|
|
get (MalHashMap hm _:MalString k:[]) = do
|
|
case Map.lookup k hm of
|
|
Just mv -> return mv
|
|
Nothing -> return Nil
|
|
get (Nil:MalString k:[]) = return Nil
|
|
get _ = throwStr "invalid call to get"
|
|
|
|
contains_Q (MalHashMap hm _:MalString k:[]) = do
|
|
if Map.member k hm then return MalTrue
|
|
else return MalFalse
|
|
contains_Q (Nil:MalString k:[]) = return MalFalse
|
|
contains_Q _ = throwStr "invalid call to contains?"
|
|
|
|
keys (MalHashMap hm _:[]) = do
|
|
return $ MalList (map MalString (Map.keys hm)) Nil
|
|
keys _ = throwStr "invalid call to keys"
|
|
|
|
vals (MalHashMap hm _:[]) = do
|
|
return $ MalList (Map.elems hm) Nil
|
|
vals _ = throwStr "invalid call to vals"
|
|
|
|
|
|
-- Sequence functions
|
|
|
|
_sequential_Q (MalList _ _) = MalTrue
|
|
_sequential_Q (MalVector _ _) = MalTrue
|
|
_sequential_Q _ = MalFalse
|
|
|
|
cons x Nil = MalList [x] Nil
|
|
cons x (MalList lst _) = MalList (x:lst) Nil
|
|
cons x (MalVector lst _) = MalList (x:lst) Nil
|
|
|
|
concat1 a (MalList lst _) = a ++ lst
|
|
concat1 a (MalVector lst _) = a ++ lst
|
|
do_concat args = return $ MalList (foldl concat1 [] args) Nil
|
|
|
|
nth ((MalList lst _):(MalNumber idx):[]) = do
|
|
if idx < length lst then return $ lst !! idx
|
|
else throwStr "nth: index out of range"
|
|
nth ((MalVector lst _):(MalNumber idx):[]) = do
|
|
if idx < length lst then return $ lst !! idx
|
|
else throwStr "nth: index out of range"
|
|
nth _ = throwStr "invalid call to nth"
|
|
|
|
first (MalList lst _) = if length lst > 0 then lst !! 0 else Nil
|
|
first (MalVector lst _) = if length lst > 0 then lst !! 0 else Nil
|
|
|
|
rest (MalList lst _) = MalList (drop 1 lst) Nil
|
|
rest (MalVector lst _) = MalList (drop 1 lst) Nil
|
|
|
|
empty_Q Nil = MalTrue
|
|
empty_Q (MalList [] _) = MalTrue
|
|
empty_Q (MalVector [] _) = MalTrue
|
|
empty_Q _ = MalFalse
|
|
|
|
count (Nil:[]) = return $ MalNumber 0
|
|
count (MalList lst _:[]) = return $ MalNumber $ length lst
|
|
count (MalVector lst _:[]) = return $ MalNumber $ length lst
|
|
count _ = throwStr $ "non-sequence passed to count"
|
|
|
|
conj ((MalList lst _):args) = return $ MalList ((reverse args) ++ lst) Nil
|
|
conj ((MalVector lst _):args) = return $ MalVector (lst ++ args) Nil
|
|
conj _ = throwStr $ "illegal arguments to conj"
|
|
|
|
apply args = do
|
|
f <- _get_call args
|
|
lst <- _to_list (last args)
|
|
f $ (init (drop 1 args)) ++ lst
|
|
|
|
do_map args = do
|
|
f <- _get_call args
|
|
lst <- _to_list (args !! 1)
|
|
do new_lst <- mapM (\x -> f [x]) lst
|
|
return $ MalList new_lst Nil
|
|
|
|
-- Metadata functions
|
|
|
|
with_meta ((MalList lst _):m:[]) = return $ MalList lst m
|
|
with_meta ((MalVector lst _):m:[]) = return $ MalVector lst m
|
|
with_meta ((MalHashMap hm _):m:[]) = return $ MalHashMap hm m
|
|
with_meta ((MalAtom atm _):m:[]) = return $ MalAtom atm m
|
|
with_meta ((Func f _):m:[]) = return $ Func f m
|
|
with_meta ((MalFunc {fn=f, ast=a, env=e, params=p, macro=mc}):m:[]) = do
|
|
return $ MalFunc {fn=f, ast=a, env=e, params=p, macro=mc, meta=m}
|
|
with_meta _ = throwStr $ "invalid with-meta call"
|
|
|
|
do_meta ((MalList _ m):[]) = return m
|
|
do_meta ((MalVector _ m):[]) = return m
|
|
do_meta ((MalHashMap _ m):[]) = return m
|
|
do_meta ((MalAtom _ m):[]) = return m
|
|
do_meta ((Func _ m):[]) = return m
|
|
do_meta ((MalFunc {meta=m}):[]) = return m
|
|
do_meta _ = throwStr $ "invalid meta call"
|
|
|
|
-- Atom functions
|
|
|
|
atom (val:[]) = do
|
|
ref <- liftIO $ newIORef val
|
|
return $ MalAtom ref Nil
|
|
atom _ = throwStr "invalid atom call"
|
|
|
|
deref (MalAtom ref _:[]) = do
|
|
val <- liftIO $ readIORef ref
|
|
return val
|
|
deref _ = throwStr "invalid deref call"
|
|
|
|
reset_BANG (MalAtom ref _:val:[]) = do
|
|
liftIO $ writeIORef ref $ val
|
|
return val
|
|
reset_BANG _ = throwStr "invalid deref call"
|
|
|
|
swap_BANG (MalAtom ref _:args) = do
|
|
val <- liftIO $ readIORef ref
|
|
f <- _get_call args
|
|
new_val <- f $ [val] ++ (tail args)
|
|
_ <- liftIO $ writeIORef ref $ new_val
|
|
return new_val
|
|
|
|
ns = [
|
|
("=", _func equal_Q),
|
|
("throw", _func throw),
|
|
("nil?", _func $ run_1 $ _nil_Q),
|
|
("true?", _func $ run_1 $ _true_Q),
|
|
("false?", _func $ run_1 $ _false_Q),
|
|
("symbol", _func $ symbol),
|
|
("symbol?", _func $ run_1 $ _symbol_Q),
|
|
("keyword", _func $ keyword),
|
|
("keyword?", _func $ run_1 $ _keyword_Q),
|
|
|
|
("pr-str", _func pr_str),
|
|
("str", _func str),
|
|
("prn", _func prn),
|
|
("println", _func println),
|
|
("readline", _func do_readline),
|
|
("read-string", _func (\[(MalString s)] -> read_str s)),
|
|
("slurp", _func slurp),
|
|
|
|
("<", _func $ cmp_op (<)),
|
|
("<=", _func $ cmp_op (<=)),
|
|
(">", _func $ cmp_op (>)),
|
|
(">=", _func $ cmp_op (>=)),
|
|
("+", _func $ num_op (+)),
|
|
("-", _func $ num_op (-)),
|
|
("*", _func $ num_op (*)),
|
|
("/", _func $ num_op (div)),
|
|
("time-ms", _func $ time_ms),
|
|
|
|
("list", _func $ list),
|
|
("list?", _func $ run_1 _list_Q),
|
|
("vector", _func $ vector),
|
|
("vector?", _func $ run_1 _vector_Q),
|
|
("hash-map", _func $ hash_map),
|
|
("map?", _func $ run_1 _hash_map_Q),
|
|
("assoc", _func $ assoc),
|
|
("dissoc", _func $ dissoc),
|
|
("get", _func $ get),
|
|
("contains?",_func $ contains_Q),
|
|
("keys", _func $ keys),
|
|
("vals", _func $ vals),
|
|
|
|
("sequential?", _func $ run_1 _sequential_Q),
|
|
("cons", _func $ run_2 $ cons),
|
|
("concat", _func $ do_concat),
|
|
("nth", _func nth),
|
|
("first", _func $ run_1 $ first),
|
|
("rest", _func $ run_1 $ rest),
|
|
("empty?", _func $ run_1 $ empty_Q),
|
|
("count", _func $ count),
|
|
("conj", _func $ conj),
|
|
("apply", _func $ apply),
|
|
("map", _func $ do_map),
|
|
|
|
("with-meta", _func $ with_meta),
|
|
("meta", _func $ do_meta),
|
|
("atom", _func $ atom),
|
|
("atom?", _func $ run_1 _atom_Q),
|
|
("deref", _func $ deref),
|
|
("reset!", _func $ reset_BANG),
|
|
("swap!", _func $ swap_BANG)]
|