mirror of
https://github.com/kanaka/mal.git
synced 2024-10-26 14:22:25 +03:00
Haskell: Add steps9-A, metadata, and atoms.
Some refactoring of Core.hs to make better use of pattern matching. Only remaining thing is exception handling (generic try/throw).
This commit is contained in:
parent
2988d38e84
commit
c150ec41f4
258
haskell/Core.hs
258
haskell/Core.hs
@ -2,29 +2,36 @@ module Core
|
||||
( ns )
|
||||
where
|
||||
|
||||
import Control.Exception (catch)
|
||||
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 args = case args of
|
||||
[a, b] -> return $ if a == b then MalTrue else MalFalse
|
||||
_ -> error $ "illegal arguments to ="
|
||||
equal_Q [a, b] = return $ if a == b then MalTrue else MalFalse
|
||||
equal_Q _ = error $ "illegal arguments to ="
|
||||
|
||||
run_1 :: (MalVal -> MalVal) -> [MalVal] -> IO MalVal
|
||||
run_1 f args = do
|
||||
case args of
|
||||
(x:[]) -> return $ f x
|
||||
_ -> error $ "function takes a single argument"
|
||||
run_1 f (x:[]) = return $ f x
|
||||
run_1 _ _ = error $ "function takes a single argument"
|
||||
|
||||
run_2 :: (MalVal -> MalVal -> MalVal) -> [MalVal] -> IO MalVal
|
||||
run_2 f args = do
|
||||
case args of
|
||||
(x:y:[]) -> return $ f x y
|
||||
_ -> error $ "function takes a two arguments"
|
||||
run_2 f (x:y:[]) = return $ f x y
|
||||
run_2 _ _ = error $ "function takes a two arguments"
|
||||
|
||||
-- Scalar functions
|
||||
|
||||
symbol (MalString str) = MalSymbol str
|
||||
symbol _ = error $ "symbol called with non-string"
|
||||
|
||||
keyword (MalString str) = MalString $ "\x029e" ++ str
|
||||
keyword _ = error $ "keyword called with non-string"
|
||||
|
||||
|
||||
-- String functions
|
||||
@ -43,85 +50,199 @@ println args = do
|
||||
putStrLn $ _pr_list False " " args
|
||||
return Nil
|
||||
|
||||
slurp args = do
|
||||
case args of
|
||||
([MalString path]) -> do
|
||||
str <- readFile path
|
||||
return $ MalString str
|
||||
_ -> error $ "invalid arguments to slurp"
|
||||
slurp ([MalString path]) = do
|
||||
str <- readFile path
|
||||
return $ MalString str
|
||||
slurp _ = error $ "invalid arguments to slurp"
|
||||
|
||||
do_readline ([MalString prompt]) = do
|
||||
str <- readline prompt
|
||||
case str of
|
||||
Nothing -> error "readline failed"
|
||||
Just str -> return $ MalString str
|
||||
do_readline _ = error $ "invalid arguments to readline"
|
||||
|
||||
-- Numeric functions
|
||||
|
||||
num_op op args = case args of
|
||||
[MalNumber a, MalNumber b] -> return $ MalNumber $ op a b
|
||||
_ -> error $ "illegal arguments to number operation"
|
||||
num_op op [MalNumber a, MalNumber b] = do
|
||||
return $ MalNumber $ op a b
|
||||
num_op _ _ = error $ "illegal arguments to number operation"
|
||||
|
||||
cmp_op op args = case args of
|
||||
[MalNumber a, MalNumber b] ->
|
||||
return $ if op a b then MalTrue else MalFalse
|
||||
_ -> error $ "illegal arguments to comparison operation"
|
||||
cmp_op op [MalNumber a, MalNumber b] = do
|
||||
return $ if op a b then MalTrue else MalFalse
|
||||
cmp_op _ _ = error $ "illegal arguments to comparison operation"
|
||||
|
||||
time_ms _ = do
|
||||
t <- getPOSIXTime
|
||||
return $ MalNumber $ round (t * 1000)
|
||||
|
||||
|
||||
-- List functions
|
||||
|
||||
list args = do
|
||||
return $ MalList args
|
||||
list args = return $ MalList args Nil
|
||||
|
||||
-- Vector functions
|
||||
|
||||
vector args = do
|
||||
return $ MalVector args
|
||||
vector args = return $ MalVector args Nil
|
||||
|
||||
-- Hash Map functions
|
||||
|
||||
_pairup [x] = error "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
|
||||
return $ MalHashMap $ Map.fromList $ _pairs args
|
||||
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 _ = error $ "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 _ = error $ "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 _ = error $ "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 _ = error $ "invalid call to contains?"
|
||||
|
||||
keys (MalHashMap hm _:[]) = do
|
||||
return $ MalList (map MalString (Map.keys hm)) Nil
|
||||
keys _ = error $ "invalid call to keys"
|
||||
|
||||
vals (MalHashMap hm _:[]) = do
|
||||
return $ MalList (Map.elems hm) Nil
|
||||
vals _ = error $ "invalid call to vals"
|
||||
|
||||
|
||||
-- Sequence functions
|
||||
|
||||
cons x Nil = MalList [x]
|
||||
cons x (MalList lst) = MalList $ x:lst
|
||||
cons x (MalVector lst) = MalList $ x:lst
|
||||
_sequential_Q (MalList _ _) = MalTrue
|
||||
_sequential_Q (MalVector _ _) = MalTrue
|
||||
_sequential_Q _ = MalFalse
|
||||
|
||||
concat1 a (MalList lst) = a ++ lst
|
||||
concat1 a (MalVector lst) = a ++ lst
|
||||
do_concat args = return $ MalList $ foldl concat1 [] args
|
||||
cons x Nil = MalList [x] Nil
|
||||
cons x (MalList lst _) = MalList (x:lst) Nil
|
||||
cons x (MalVector lst _) = MalList (x:lst) Nil
|
||||
|
||||
nth args = do
|
||||
case args of
|
||||
(MalList lst):(MalNumber idx):[] ->
|
||||
if idx < length lst then return $ lst !! idx
|
||||
else error "nth: index out of range"
|
||||
(MalVector lst):(MalNumber idx):[] ->
|
||||
if idx < length lst then return $ lst !! idx
|
||||
else error "nth: index out of range"
|
||||
concat1 a (MalList lst _) = a ++ lst
|
||||
concat1 a (MalVector lst _) = a ++ lst
|
||||
do_concat args = return $ MalList (foldl concat1 [] args) Nil
|
||||
|
||||
first (MalList lst) = if length lst > 0 then lst !! 0 else Nil
|
||||
first (MalVector lst) = if length lst > 0 then lst !! 0 else Nil
|
||||
nth ((MalList lst _):(MalNumber idx):[]) = do
|
||||
if idx < length lst then return $ lst !! idx
|
||||
else error "nth: index out of range"
|
||||
nth ((MalVector lst _):(MalNumber idx):[]) = do
|
||||
if idx < length lst then return $ lst !! idx
|
||||
else error "nth: index out of range"
|
||||
nth _ = error "invalid call to nth"
|
||||
|
||||
rest (MalList lst) = MalList $ drop 1 lst
|
||||
rest (MalVector lst) = MalList $ drop 1 lst
|
||||
first (MalList lst _) = if length lst > 0 then lst !! 0 else Nil
|
||||
first (MalVector lst _) = if length lst > 0 then lst !! 0 else Nil
|
||||
|
||||
empty_Q Nil = MalTrue
|
||||
empty_Q (MalList []) = MalTrue
|
||||
empty_Q (MalVector []) = MalTrue
|
||||
empty_Q _ = MalFalse
|
||||
rest (MalList lst _) = MalList (drop 1 lst) Nil
|
||||
rest (MalVector lst _) = MalList (drop 1 lst) Nil
|
||||
|
||||
count Nil = MalNumber 0
|
||||
count (MalList lst) = MalNumber $ length lst
|
||||
count (MalVector lst) = MalNumber $ length lst
|
||||
empty_Q Nil = MalTrue
|
||||
empty_Q (MalList [] _) = MalTrue
|
||||
empty_Q (MalVector [] _) = MalTrue
|
||||
empty_Q _ = MalFalse
|
||||
|
||||
count Nil = MalNumber 0
|
||||
count (MalList lst _) = MalNumber $ length lst
|
||||
count (MalVector lst _) = MalNumber $ length lst
|
||||
count _ = error $ "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 _ = error $ "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 _ = error $ "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 _ = error $ "invalid meta call"
|
||||
|
||||
-- Atom functions
|
||||
|
||||
atom (val:[]) = do
|
||||
ref <- newIORef val
|
||||
return $ MalAtom ref Nil
|
||||
atom _ = error "invalid atom call"
|
||||
|
||||
deref (MalAtom ref _:[]) = do
|
||||
val <- readIORef ref
|
||||
return val
|
||||
deref _ = error "invalid deref call"
|
||||
|
||||
reset_BANG (MalAtom ref _:val:[]) = do
|
||||
_ <- writeIORef ref $ val
|
||||
return val
|
||||
reset_BANG _ = error "invalid deref call"
|
||||
|
||||
swap_BANG (MalAtom ref _:args) = do
|
||||
val <- readIORef ref
|
||||
f <- _get_call args
|
||||
new_val <- f $ [val] ++ (tail args)
|
||||
_ <- writeIORef ref $ new_val
|
||||
return new_val
|
||||
|
||||
ns = [
|
||||
("=", _func equal_Q),
|
||||
("nil?", _func $ run_1 $ _nil_Q),
|
||||
("true?", _func $ run_1 $ _true_Q),
|
||||
("false?", _func $ run_1 $ _false_Q),
|
||||
("symbol", _func $ run_1 $ symbol),
|
||||
("symbol?", _func $ run_1 $ _symbol_Q),
|
||||
("keyword", _func $ run_1 $ 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 (>)),
|
||||
@ -130,18 +251,37 @@ ns = [
|
||||
("-", _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),
|
||||
("vector?", _func $ run_1 _vector_Q),
|
||||
("hash-map", _func $ hash_map),
|
||||
("map?", _func $ run_1 $ _hash_map_Q),
|
||||
|
||||
("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 $ run_1 $ count)]
|
||||
("empty?", _func $ run_1 $ empty_Q),
|
||||
("count", _func $ run_1 $ 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)]
|
||||
|
@ -31,7 +31,7 @@ env_bind envRef binds exprs = do
|
||||
_ <- mapM (\(b,e) -> env_set envRef b e) $
|
||||
zip (take idx binds) (take idx exprs)
|
||||
_ <- env_set envRef (binds !! (idx + 1))
|
||||
(MalList (drop idx exprs))
|
||||
(MalList (drop idx exprs) Nil)
|
||||
return envRef
|
||||
|
||||
{-
|
||||
|
@ -1,12 +1,12 @@
|
||||
SOURCES_BASE =
|
||||
SOURCES_LISP = step0_repl.hs
|
||||
SOURCES_BASE = Readline.hs Types.hs Reader.hs Printer.hs
|
||||
SOURCES_LISP = Env.hs Core.hs step9_try.hs
|
||||
SOURCES = $(SOURCES_BASE) $(SOURCES_LISP)
|
||||
|
||||
#####################
|
||||
|
||||
SRCS = step0_repl.hs step1_read_print.hs step2_eval.hs step3_env.hs \
|
||||
step4_if_fn_do.hs step5_tco.hs step6_file.hs step7_quote.hs \
|
||||
step8_macros.hs
|
||||
step8_macros.hs step9_try.hs stepA_interop.hs
|
||||
OTHER_SRCS = Readline.hs Types.hs Reader.hs Printer.hs Env.hs Core.hs
|
||||
BINS = $(SRCS:%.hs=%)
|
||||
|
||||
|
@ -3,6 +3,8 @@ module Printer
|
||||
where
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import Data.IORef (readIORef)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
import Types
|
||||
|
||||
@ -30,15 +32,15 @@ _pr_str _ (MalString ('\x029e':str)) = ":" ++ str
|
||||
_pr_str True (MalString str) = "\"" ++ concatMap unescape str ++ "\""
|
||||
_pr_str False (MalString str) = str
|
||||
_pr_str _ (MalSymbol name) = name
|
||||
_pr_str _ (MalKeyword name) = ":" ++ name
|
||||
_pr_str _ (MalNumber num) = show num
|
||||
_pr_str _ (MalTrue) = "true"
|
||||
_pr_str _ (MalFalse) = "false"
|
||||
_pr_str _ (Nil) = "nil"
|
||||
_pr_str pr (MalList items) = "(" ++ (_pr_list pr " " items) ++ ")"
|
||||
_pr_str pr (MalVector items) = "[" ++ (_pr_list pr " " items) ++ "]"
|
||||
_pr_str pr (MalHashMap m) = "{" ++ (_pr_list pr " " (_flatTuples $ Map.assocs m)) ++ "}"
|
||||
_pr_str _ (Func f) = "#<function>"
|
||||
_pr_str pr (MalList items _) = "(" ++ (_pr_list pr " " items) ++ ")"
|
||||
_pr_str pr (MalVector items _) = "[" ++ (_pr_list pr " " items) ++ "]"
|
||||
_pr_str pr (MalHashMap m _) = "{" ++ (_pr_list pr " " (_flatTuples $ Map.assocs m)) ++ "}"
|
||||
_pr_str pr (MalAtom r _) = "(atom " ++ (_pr_str pr (unsafePerformIO (readIORef r))) ++ ")"
|
||||
_pr_str _ (Func f _) = "#<function>"
|
||||
_pr_str _ (MalFunc {ast=ast, env=fn_env, params=params}) = "(fn* " ++ (show params) ++ " " ++ (show ast) ++ ")"
|
||||
|
||||
instance Show MalVal where show = _pr_str True
|
||||
|
@ -57,7 +57,7 @@ read_keyword :: Parser MalVal
|
||||
read_keyword = do
|
||||
char ':'
|
||||
x <- many (letter <|> digit <|> symbol)
|
||||
return $ MalKeyword x
|
||||
return $ MalString $ "\x029e" ++ x
|
||||
|
||||
read_atom :: Parser MalVal
|
||||
read_atom = read_number
|
||||
@ -70,52 +70,74 @@ read_list = do
|
||||
char '('
|
||||
x <- sepEndBy read_form ignored
|
||||
char ')'
|
||||
return $ MalList x
|
||||
return $ MalList x Nil
|
||||
|
||||
read_vector :: Parser MalVal
|
||||
read_vector = do
|
||||
char '['
|
||||
x <- sepEndBy read_form ignored
|
||||
char ']'
|
||||
return $ MalVector x
|
||||
return $ MalVector x Nil
|
||||
|
||||
-- TODO: propagate error properly
|
||||
_pairs [x] = error "Odd number of elements to _pairs"
|
||||
_pairs [] = []
|
||||
_pairs (MalString x:y:xs) = (x,y):_pairs xs
|
||||
|
||||
read_hash_map :: Parser MalVal
|
||||
read_hash_map = do
|
||||
char '{'
|
||||
x <- sepEndBy read_form ignored
|
||||
char '}'
|
||||
return $ MalHashMap $ Map.fromList $ _pairs x
|
||||
return $ MalHashMap (Map.fromList $ _pairs x) Nil
|
||||
|
||||
-- reader macros
|
||||
read_quote :: Parser MalVal
|
||||
read_quote = do
|
||||
char '\''
|
||||
x <- read_form
|
||||
return $ MalList [MalSymbol "quote", x]
|
||||
return $ MalList [MalSymbol "quote", x] Nil
|
||||
|
||||
read_quasiquote :: Parser MalVal
|
||||
read_quasiquote = do
|
||||
char '`'
|
||||
x <- read_form
|
||||
return $ MalList [MalSymbol "quasiquote", x]
|
||||
return $ MalList [MalSymbol "quasiquote", x] Nil
|
||||
|
||||
read_splice_unquote :: Parser MalVal
|
||||
read_splice_unquote = do
|
||||
char '~'
|
||||
char '@'
|
||||
x <- read_form
|
||||
return $ MalList [MalSymbol "splice-unquote", x]
|
||||
return $ MalList [MalSymbol "splice-unquote", x] Nil
|
||||
|
||||
read_unquote :: Parser MalVal
|
||||
read_unquote = do
|
||||
char '~'
|
||||
x <- read_form
|
||||
return $ MalList [MalSymbol "unquote", x]
|
||||
return $ MalList [MalSymbol "unquote", x] Nil
|
||||
|
||||
read_deref :: Parser MalVal
|
||||
read_deref = do
|
||||
char '@'
|
||||
x <- read_form
|
||||
return $ MalList [MalSymbol "deref", x] Nil
|
||||
|
||||
read_with_meta :: Parser MalVal
|
||||
read_with_meta = do
|
||||
char '^'
|
||||
m <- read_form
|
||||
x <- read_form
|
||||
return $ MalList [MalSymbol "with-meta", x, m] Nil
|
||||
|
||||
read_macro :: Parser MalVal
|
||||
read_macro = read_quote
|
||||
<|> read_quasiquote
|
||||
<|> try read_splice_unquote <|> read_unquote
|
||||
<|> read_deref
|
||||
<|> read_with_meta
|
||||
|
||||
--
|
||||
|
||||
read_form :: Parser MalVal
|
||||
read_form = do
|
||||
|
@ -1,6 +1,9 @@
|
||||
module Types
|
||||
(MalVal (..), Fn (..), EnvData (..), Env,
|
||||
catchAny, _pairs, _func, _malfunc, _list_Q, _vector_Q, _hash_map_Q)
|
||||
_get_call, _to_list,
|
||||
catchAny, _func, _malfunc,
|
||||
_nil_Q, _true_Q, _false_Q, _symbol_Q, _keyword_Q,
|
||||
_list_Q, _vector_Q, _hash_map_Q, _atom_Q)
|
||||
where
|
||||
|
||||
import Data.IORef (IORef)
|
||||
@ -16,16 +19,17 @@ data MalVal = Nil
|
||||
| MalNumber Int
|
||||
| MalString String
|
||||
| MalSymbol String
|
||||
| MalKeyword String
|
||||
| MalList [MalVal]
|
||||
| MalVector [MalVal]
|
||||
| MalHashMap (Map.Map String MalVal)
|
||||
| Func Fn
|
||||
| MalFunc {fn :: Fn,
|
||||
ast :: MalVal,
|
||||
env :: Env,
|
||||
params :: MalVal,
|
||||
macro :: Bool}
|
||||
| MalList [MalVal] MalVal
|
||||
| MalVector [MalVal] MalVal
|
||||
| MalHashMap (Map.Map String MalVal) MalVal
|
||||
| MalAtom (IORef MalVal) MalVal
|
||||
| Func Fn MalVal
|
||||
| MalFunc {fn :: Fn,
|
||||
ast :: MalVal,
|
||||
env :: Env,
|
||||
params :: MalVal,
|
||||
macro :: Bool,
|
||||
meta :: MalVal}
|
||||
|
||||
_equal_Q Nil Nil = True
|
||||
_equal_Q MalFalse MalFalse = True
|
||||
@ -33,11 +37,11 @@ _equal_Q MalTrue MalTrue = True
|
||||
_equal_Q (MalNumber a) (MalNumber b) = a == b
|
||||
_equal_Q (MalString a) (MalString b) = a == b
|
||||
_equal_Q (MalSymbol a) (MalSymbol b) = a == b
|
||||
_equal_Q (MalKeyword a) (MalKeyword b) = a == b
|
||||
_equal_Q (MalList a) (MalList b) = a == b
|
||||
_equal_Q (MalList a) (MalVector b) = a == b
|
||||
_equal_Q (MalVector a) (MalList b) = a == b
|
||||
_equal_Q (MalHashMap a) (MalHashMap b) = a == b
|
||||
_equal_Q (MalList a _) (MalList b _) = a == b
|
||||
_equal_Q (MalList a _) (MalVector b _) = a == b
|
||||
_equal_Q (MalVector a _) (MalList b _) = a == b
|
||||
_equal_Q (MalHashMap a _) (MalHashMap b _) = a == b
|
||||
_equal_Q (MalAtom a _) (MalAtom b _) = a == b
|
||||
_equal_Q _ _ = False
|
||||
|
||||
instance Eq MalVal where
|
||||
@ -55,23 +59,13 @@ type Env = IORef EnvData
|
||||
|
||||
-- General functions --
|
||||
|
||||
_obj_type :: MalVal -> String
|
||||
_obj_type (Nil) = "nil"
|
||||
_obj_type (MalFalse) = "false"
|
||||
_obj_type (MalTrue) = "true"
|
||||
_obj_type (MalNumber _) = "number"
|
||||
_obj_type (MalString _) = "string"
|
||||
_obj_type (MalSymbol _) = "symbol"
|
||||
_obj_type (MalList _) = "list"
|
||||
_obj_type (MalVector _) = "vector"
|
||||
_obj_type (MalHashMap _) = "hashmap"
|
||||
_obj_type (Func _) = "function"
|
||||
_get_call ((Func (Fn f) _) : _) = return f
|
||||
_get_call (MalFunc {fn=(Fn f)} : _) = return f
|
||||
_get_call _ = error $ "first parameter is not a function "
|
||||
|
||||
-- TODO: propagate error properly
|
||||
_pairs [x] = error "Odd number of elements to _pairs"
|
||||
_pairs [] = []
|
||||
_pairs (MalString x:y:xs) = (x,y):_pairs xs
|
||||
_pairs (MalKeyword x:y:xs) = ("\x029e" ++ x,y):_pairs xs
|
||||
_to_list (MalList lst _) = return lst
|
||||
_to_list (MalVector lst _) = return lst
|
||||
_to_list _ = error $ "expected a MalList or MalVector"
|
||||
|
||||
-- Errors
|
||||
|
||||
@ -81,23 +75,48 @@ catchAny = CE.catch
|
||||
|
||||
-- Functions
|
||||
|
||||
_func fn = Func $ Fn fn
|
||||
_func fn = Func (Fn fn) Nil
|
||||
_func_meta fn meta = Func (Fn fn) meta
|
||||
|
||||
_malfunc ast env params fn = MalFunc {fn=(Fn fn), ast=ast,
|
||||
env=env, params=params,
|
||||
macro=False}
|
||||
macro=False, meta=Nil}
|
||||
_malfunc_meta ast env params fn meta = MalFunc {fn=(Fn fn), ast=ast,
|
||||
env=env, params=params,
|
||||
macro=False, meta=meta}
|
||||
|
||||
-- Scalars
|
||||
_nil_Q Nil = MalTrue
|
||||
_nil_Q _ = MalFalse
|
||||
|
||||
_true_Q MalTrue = MalTrue
|
||||
_true_Q _ = MalFalse
|
||||
|
||||
_false_Q MalFalse = MalTrue
|
||||
_false_Q _ = MalFalse
|
||||
|
||||
_symbol_Q (MalSymbol _) = MalTrue
|
||||
_symbol_Q _ = MalFalse
|
||||
|
||||
_keyword_Q (MalString ('\x029e':_)) = MalTrue
|
||||
_keyword_Q _ = MalFalse
|
||||
|
||||
-- Lists
|
||||
|
||||
_list_Q (MalList _) = MalTrue
|
||||
_list_Q _ = MalFalse
|
||||
_list_Q (MalList _ _) = MalTrue
|
||||
_list_Q _ = MalFalse
|
||||
|
||||
-- Vectors
|
||||
|
||||
_vector_Q (MalVector _) = MalTrue
|
||||
_vector_Q _ = MalFalse
|
||||
_vector_Q (MalVector _ _) = MalTrue
|
||||
_vector_Q _ = MalFalse
|
||||
|
||||
-- Hash Maps
|
||||
|
||||
_hash_map_Q (MalHashMap _) = MalTrue
|
||||
_hash_map_Q _ = MalFalse
|
||||
_hash_map_Q (MalHashMap _ _) = MalTrue
|
||||
_hash_map_Q _ = MalFalse
|
||||
|
||||
-- Atoms
|
||||
|
||||
_atom_Q (MalAtom _ _) = MalTrue
|
||||
_atom_Q _ = MalFalse
|
||||
|
@ -18,22 +18,22 @@ eval_ast (MalSymbol sym) env = do
|
||||
case Map.lookup sym env of
|
||||
Nothing -> error $ "'" ++ sym ++ "' not found"
|
||||
Just v -> return v
|
||||
eval_ast ast@(MalList lst) env = do
|
||||
eval_ast ast@(MalList lst m) env = do
|
||||
new_lst <- mapM (\x -> (eval x env)) lst
|
||||
return $ MalList new_lst
|
||||
eval_ast ast@(MalVector lst) env = do
|
||||
return $ MalList new_lst m
|
||||
eval_ast ast@(MalVector lst m) env = do
|
||||
new_lst <- mapM (\x -> (eval x env)) lst
|
||||
return $ MalVector new_lst
|
||||
eval_ast ast@(MalHashMap lst) env = do
|
||||
return $ MalVector new_lst m
|
||||
eval_ast ast@(MalHashMap lst m) env = do
|
||||
new_hm <- DT.mapM (\x -> (eval x env)) lst
|
||||
return $ MalHashMap new_hm
|
||||
return $ MalHashMap new_hm m
|
||||
eval_ast ast env = return ast
|
||||
|
||||
apply_ast :: MalVal -> (Map.Map String MalVal) -> IO MalVal
|
||||
apply_ast ast@(MalList _) env = do
|
||||
apply_ast ast@(MalList _ _) env = do
|
||||
el <- eval_ast ast env
|
||||
case el of
|
||||
(MalList (Func (Fn f) : rest)) ->
|
||||
(MalList ((Func (Fn f) _) : rest) _) ->
|
||||
f $ rest
|
||||
el ->
|
||||
error $ "invalid apply: " ++ (show el)
|
||||
@ -41,7 +41,7 @@ apply_ast ast@(MalList _) env = do
|
||||
eval :: MalVal -> (Map.Map String MalVal) -> IO MalVal
|
||||
eval ast env = do
|
||||
case ast of
|
||||
(MalList lst) -> apply_ast ast env
|
||||
(MalList _ _) -> apply_ast ast env
|
||||
_ -> eval_ast ast env
|
||||
|
||||
|
||||
@ -50,18 +50,14 @@ mal_print :: MalVal -> String
|
||||
mal_print exp = show exp
|
||||
|
||||
-- repl
|
||||
add args = case args of
|
||||
[MalNumber a, MalNumber b] -> return $ MalNumber $ a + b
|
||||
_ -> error $ "illegal arguments to +"
|
||||
sub args = case args of
|
||||
[MalNumber a, MalNumber b] -> return $ MalNumber $ a - b
|
||||
_ -> error $ "illegal arguments to -"
|
||||
mult args = case args of
|
||||
[MalNumber a, MalNumber b] -> return $ MalNumber $ a * b
|
||||
_ -> error $ "illegal arguments to *"
|
||||
divd args = case args of
|
||||
[MalNumber a, MalNumber b] -> return $ MalNumber $ a `div` b
|
||||
_ -> error $ "illegal arguments to /"
|
||||
add [MalNumber a, MalNumber b] = return $ MalNumber $ a + b
|
||||
add _ = error $ "illegal arguments to +"
|
||||
sub [MalNumber a, MalNumber b] = return $ MalNumber $ a - b
|
||||
sub _ = error $ "illegal arguments to -"
|
||||
mult [MalNumber a, MalNumber b] = return $ MalNumber $ a * b
|
||||
mult _ = error $ "illegal arguments to *"
|
||||
divd [MalNumber a, MalNumber b] = return $ MalNumber $ a `div` b
|
||||
divd _ = error $ "illegal arguments to /"
|
||||
|
||||
repl_env :: Map.Map String MalVal
|
||||
repl_env = Map.fromList [("+", _func add),
|
||||
|
@ -16,15 +16,15 @@ mal_read str = read_str str
|
||||
-- eval
|
||||
eval_ast :: MalVal -> Env -> IO MalVal
|
||||
eval_ast sym@(MalSymbol _) env = env_get env sym
|
||||
eval_ast ast@(MalList lst) env = do
|
||||
eval_ast ast@(MalList lst m) env = do
|
||||
new_lst <- mapM (\x -> (eval x env)) lst
|
||||
return $ MalList new_lst
|
||||
eval_ast ast@(MalVector lst) env = do
|
||||
return $ MalList new_lst m
|
||||
eval_ast ast@(MalVector lst m) env = do
|
||||
new_lst <- mapM (\x -> (eval x env)) lst
|
||||
return $ MalVector new_lst
|
||||
eval_ast ast@(MalHashMap lst) env = do
|
||||
return $ MalVector new_lst m
|
||||
eval_ast ast@(MalHashMap lst m) env = do
|
||||
new_hm <- DT.mapM (\x -> (eval x env)) lst
|
||||
return $ MalHashMap new_hm
|
||||
return $ MalHashMap new_hm m
|
||||
eval_ast ast env = return ast
|
||||
|
||||
let_bind :: Env -> [MalVal] -> IO Env
|
||||
@ -35,27 +35,24 @@ let_bind env (b:e:xs) = do
|
||||
let_bind env xs
|
||||
|
||||
apply_ast :: MalVal -> Env -> IO MalVal
|
||||
apply_ast ast@(MalList (MalSymbol "def!" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do
|
||||
case args of
|
||||
(a1@(MalSymbol _): a2 : []) -> do
|
||||
evaled <- eval a2 env
|
||||
env_set env a1 evaled
|
||||
_ -> error $ "invalid def!"
|
||||
apply_ast ast@(MalList (MalSymbol "let*" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do
|
||||
case args of
|
||||
(MalList a1 : a2 : []) -> do
|
||||
(a1 : a2 : []) -> do
|
||||
params <- (_to_list a1)
|
||||
let_env <- env_new $ Just env
|
||||
let_bind let_env a1
|
||||
eval a2 let_env
|
||||
(MalVector a1 : a2 : []) -> do
|
||||
let_env <- env_new $ Just env
|
||||
let_bind let_env a1
|
||||
let_bind let_env params
|
||||
eval a2 let_env
|
||||
_ -> error $ "invalid let*"
|
||||
apply_ast ast@(MalList _) env = do
|
||||
apply_ast ast@(MalList _ _) env = do
|
||||
el <- eval_ast ast env
|
||||
case el of
|
||||
(MalList (Func (Fn f) : rest)) ->
|
||||
(MalList ((Func (Fn f) _) : rest) _) ->
|
||||
f $ rest
|
||||
el ->
|
||||
error $ "invalid apply: " ++ (show el)
|
||||
@ -63,7 +60,7 @@ apply_ast ast@(MalList _) env = do
|
||||
eval :: MalVal -> Env -> IO MalVal
|
||||
eval ast env = do
|
||||
case ast of
|
||||
(MalList lst) -> apply_ast ast env
|
||||
(MalList _ _) -> apply_ast ast env
|
||||
_ -> eval_ast ast env
|
||||
|
||||
|
||||
@ -72,18 +69,14 @@ mal_print :: MalVal -> String
|
||||
mal_print exp = show exp
|
||||
|
||||
-- repl
|
||||
add args = case args of
|
||||
[MalNumber a, MalNumber b] -> return $ MalNumber $ a + b
|
||||
_ -> error $ "illegal arguments to +"
|
||||
sub args = case args of
|
||||
[MalNumber a, MalNumber b] -> return $ MalNumber $ a - b
|
||||
_ -> error $ "illegal arguments to -"
|
||||
mult args = case args of
|
||||
[MalNumber a, MalNumber b] -> return $ MalNumber $ a * b
|
||||
_ -> error $ "illegal arguments to *"
|
||||
divd args = case args of
|
||||
[MalNumber a, MalNumber b] -> return $ MalNumber $ a `div` b
|
||||
_ -> error $ "illegal arguments to /"
|
||||
add [MalNumber a, MalNumber b] = return $ MalNumber $ a + b
|
||||
add _ = error $ "illegal arguments to +"
|
||||
sub [MalNumber a, MalNumber b] = return $ MalNumber $ a - b
|
||||
sub _ = error $ "illegal arguments to -"
|
||||
mult [MalNumber a, MalNumber b] = return $ MalNumber $ a * b
|
||||
mult _ = error $ "illegal arguments to *"
|
||||
divd [MalNumber a, MalNumber b] = return $ MalNumber $ a `div` b
|
||||
divd _ = error $ "illegal arguments to /"
|
||||
|
||||
rep :: Env -> String -> IO String
|
||||
rep env line = do
|
||||
@ -105,6 +98,7 @@ repl_loop env = do
|
||||
|
||||
main = do
|
||||
load_history
|
||||
|
||||
repl_env <- env_new Nothing
|
||||
env_set repl_env (MalSymbol "+") $ _func add
|
||||
env_set repl_env (MalSymbol "-") $ _func sub
|
||||
|
@ -17,15 +17,15 @@ mal_read str = read_str str
|
||||
-- eval
|
||||
eval_ast :: MalVal -> Env -> IO MalVal
|
||||
eval_ast sym@(MalSymbol _) env = env_get env sym
|
||||
eval_ast ast@(MalList lst) env = do
|
||||
eval_ast ast@(MalList lst m) env = do
|
||||
new_lst <- mapM (\x -> (eval x env)) lst
|
||||
return $ MalList new_lst
|
||||
eval_ast ast@(MalVector lst) env = do
|
||||
return $ MalList new_lst m
|
||||
eval_ast ast@(MalVector lst m) env = do
|
||||
new_lst <- mapM (\x -> (eval x env)) lst
|
||||
return $ MalVector new_lst
|
||||
eval_ast ast@(MalHashMap lst) env = do
|
||||
return $ MalVector new_lst m
|
||||
eval_ast ast@(MalHashMap lst m) env = do
|
||||
new_hm <- DT.mapM (\x -> (eval x env)) lst
|
||||
return $ MalHashMap new_hm
|
||||
return $ MalHashMap new_hm m
|
||||
eval_ast ast env = return ast
|
||||
|
||||
let_bind :: Env -> [MalVal] -> IO Env
|
||||
@ -36,32 +36,29 @@ let_bind env (b:e:xs) = do
|
||||
let_bind env xs
|
||||
|
||||
apply_ast :: MalVal -> Env -> IO MalVal
|
||||
apply_ast ast@(MalList (MalSymbol "def!" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do
|
||||
case args of
|
||||
(a1@(MalSymbol _): a2 : []) -> do
|
||||
evaled <- eval a2 env
|
||||
env_set env a1 evaled
|
||||
_ -> error $ "invalid def!"
|
||||
apply_ast ast@(MalList (MalSymbol "let*" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do
|
||||
case args of
|
||||
(MalList a1 : a2 : []) -> do
|
||||
(a1 : a2 : []) -> do
|
||||
params <- (_to_list a1)
|
||||
let_env <- env_new $ Just env
|
||||
let_bind let_env a1
|
||||
eval a2 let_env
|
||||
(MalVector a1 : a2 : []) -> do
|
||||
let_env <- env_new $ Just env
|
||||
let_bind let_env a1
|
||||
let_bind let_env params
|
||||
eval a2 let_env
|
||||
_ -> error $ "invalid let*"
|
||||
apply_ast ast@(MalList (MalSymbol "do" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
|
||||
case args of
|
||||
([]) -> return Nil
|
||||
_ -> do
|
||||
el <- eval_ast (MalList args) env
|
||||
el <- eval_ast (MalList args Nil) env
|
||||
case el of
|
||||
(MalList el) -> return $ last el
|
||||
(MalList lst _) -> return $ last lst
|
||||
|
||||
apply_ast ast@(MalList (MalSymbol "if" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : a3 : []) -> do
|
||||
cond <- eval a1 env
|
||||
@ -74,23 +71,20 @@ apply_ast ast@(MalList (MalSymbol "if" : args)) env = do
|
||||
then return Nil
|
||||
else eval a2 env
|
||||
_ -> error $ "invalid if"
|
||||
apply_ast ast@(MalList (MalSymbol "fn*" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do
|
||||
case args of
|
||||
((MalList binds) : a2 : []) -> do
|
||||
return $ _func (\args -> do
|
||||
fn_env1 <- env_new $ Just env
|
||||
fn_env2 <- (env_bind fn_env1 binds args)
|
||||
eval a2 fn_env2)
|
||||
((MalVector binds) : a2 : []) -> do
|
||||
return $ _func (\args -> do
|
||||
fn_env1 <- env_new $ Just env
|
||||
fn_env2 <- (env_bind fn_env1 binds args)
|
||||
eval a2 fn_env2)
|
||||
(a1 : a2 : []) -> do
|
||||
params <- (_to_list a1)
|
||||
return $ (_func
|
||||
(\args -> do
|
||||
fn_env1 <- env_new $ Just env
|
||||
fn_env2 <- (env_bind fn_env1 params args)
|
||||
eval a2 fn_env2))
|
||||
_ -> error $ "invalid fn*"
|
||||
apply_ast ast@(MalList _) env = do
|
||||
apply_ast ast@(MalList _ _) env = do
|
||||
el <- eval_ast ast env
|
||||
case el of
|
||||
(MalList (Func (Fn f) : rest)) ->
|
||||
(MalList ((Func (Fn f) _) : rest) _) ->
|
||||
f $ rest
|
||||
el ->
|
||||
error $ "invalid apply: " ++ (show el)
|
||||
@ -98,7 +92,7 @@ apply_ast ast@(MalList _) env = do
|
||||
eval :: MalVal -> Env -> IO MalVal
|
||||
eval ast env = do
|
||||
case ast of
|
||||
(MalList lst) -> apply_ast ast env
|
||||
(MalList _ _) -> apply_ast ast env
|
||||
_ -> eval_ast ast env
|
||||
|
||||
|
||||
|
@ -17,15 +17,15 @@ mal_read str = read_str str
|
||||
-- eval
|
||||
eval_ast :: MalVal -> Env -> IO MalVal
|
||||
eval_ast sym@(MalSymbol _) env = env_get env sym
|
||||
eval_ast ast@(MalList lst) env = do
|
||||
eval_ast ast@(MalList lst m) env = do
|
||||
new_lst <- mapM (\x -> (eval x env)) lst
|
||||
return $ MalList new_lst
|
||||
eval_ast ast@(MalVector lst) env = do
|
||||
return $ MalList new_lst m
|
||||
eval_ast ast@(MalVector lst m) env = do
|
||||
new_lst <- mapM (\x -> (eval x env)) lst
|
||||
return $ MalVector new_lst
|
||||
eval_ast ast@(MalHashMap lst) env = do
|
||||
return $ MalVector new_lst m
|
||||
eval_ast ast@(MalHashMap lst m) env = do
|
||||
new_hm <- DT.mapM (\x -> (eval x env)) lst
|
||||
return $ MalHashMap new_hm
|
||||
return $ MalHashMap new_hm m
|
||||
eval_ast ast env = return ast
|
||||
|
||||
let_bind :: Env -> [MalVal] -> IO Env
|
||||
@ -36,32 +36,29 @@ let_bind env (b:e:xs) = do
|
||||
let_bind env xs
|
||||
|
||||
apply_ast :: MalVal -> Env -> IO MalVal
|
||||
apply_ast ast@(MalList (MalSymbol "def!" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do
|
||||
case args of
|
||||
(a1@(MalSymbol _): a2 : []) -> do
|
||||
evaled <- eval a2 env
|
||||
env_set env a1 evaled
|
||||
_ -> error $ "invalid def!"
|
||||
apply_ast ast@(MalList (MalSymbol "let*" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do
|
||||
case args of
|
||||
(MalList a1 : a2 : []) -> do
|
||||
(a1 : a2 : []) -> do
|
||||
params <- (_to_list a1)
|
||||
let_env <- env_new $ Just env
|
||||
let_bind let_env a1
|
||||
eval a2 let_env
|
||||
(MalVector a1 : a2 : []) -> do
|
||||
let_env <- env_new $ Just env
|
||||
let_bind let_env a1
|
||||
let_bind let_env params
|
||||
eval a2 let_env
|
||||
_ -> error $ "invalid let*"
|
||||
apply_ast ast@(MalList (MalSymbol "do" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
|
||||
case args of
|
||||
([]) -> return Nil
|
||||
_ -> do
|
||||
el <- eval_ast (MalList args) env
|
||||
el <- eval_ast (MalList args Nil) env
|
||||
case el of
|
||||
(MalList el) -> return $ last el
|
||||
(MalList lst _) -> return $ last lst
|
||||
|
||||
apply_ast ast@(MalList (MalSymbol "if" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : a3 : []) -> do
|
||||
cond <- eval a1 env
|
||||
@ -74,23 +71,22 @@ apply_ast ast@(MalList (MalSymbol "if" : args)) env = do
|
||||
then return Nil
|
||||
else eval a2 env
|
||||
_ -> error $ "invalid if"
|
||||
apply_ast ast@(MalList (MalSymbol "fn*" : args)) env = do
|
||||
let params = case args of
|
||||
((MalList lst) : _) -> lst
|
||||
((MalVector lst) : _) -> lst in
|
||||
case args of
|
||||
(a1 : a2 : []) -> do
|
||||
return $ (_malfunc a2 env a1 (\args -> do
|
||||
fn_env1 <- env_new $ Just env
|
||||
fn_env2 <- (env_bind fn_env1 params args)
|
||||
eval a2 fn_env2))
|
||||
_ -> error $ "invalid fn*"
|
||||
apply_ast ast@(MalList _) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : []) -> do
|
||||
params <- (_to_list a1)
|
||||
return $ (_malfunc a2 env (MalList params Nil)
|
||||
(\args -> do
|
||||
fn_env1 <- env_new $ Just env
|
||||
fn_env2 <- (env_bind fn_env1 params args)
|
||||
eval a2 fn_env2))
|
||||
_ -> error $ "invalid fn*"
|
||||
apply_ast ast@(MalList _ _) env = do
|
||||
el <- eval_ast ast env
|
||||
case el of
|
||||
(MalList (Func (Fn f) : rest)) ->
|
||||
(MalList ((Func (Fn f) _) : rest) _) ->
|
||||
f $ rest
|
||||
(MalList (MalFunc {ast=ast, env=fn_env, params=(MalList params)} : rest)) -> do
|
||||
(MalList ((MalFunc {ast=ast, env=fn_env, params=(MalList params Nil)}) : rest) _) -> do
|
||||
fn_env1 <- env_new $ Just fn_env
|
||||
fn_env2 <- (env_bind fn_env1 params rest)
|
||||
eval ast fn_env2
|
||||
@ -100,7 +96,7 @@ apply_ast ast@(MalList _) env = do
|
||||
eval :: MalVal -> Env -> IO MalVal
|
||||
eval ast env = do
|
||||
case ast of
|
||||
(MalList lst) -> apply_ast ast env
|
||||
(MalList _ _) -> apply_ast ast env
|
||||
_ -> eval_ast ast env
|
||||
|
||||
|
||||
|
@ -18,15 +18,15 @@ mal_read str = read_str str
|
||||
-- eval
|
||||
eval_ast :: MalVal -> Env -> IO MalVal
|
||||
eval_ast sym@(MalSymbol _) env = env_get env sym
|
||||
eval_ast ast@(MalList lst) env = do
|
||||
eval_ast ast@(MalList lst m) env = do
|
||||
new_lst <- mapM (\x -> (eval x env)) lst
|
||||
return $ MalList new_lst
|
||||
eval_ast ast@(MalVector lst) env = do
|
||||
return $ MalList new_lst m
|
||||
eval_ast ast@(MalVector lst m) env = do
|
||||
new_lst <- mapM (\x -> (eval x env)) lst
|
||||
return $ MalVector new_lst
|
||||
eval_ast ast@(MalHashMap lst) env = do
|
||||
return $ MalVector new_lst m
|
||||
eval_ast ast@(MalHashMap lst m) env = do
|
||||
new_hm <- DT.mapM (\x -> (eval x env)) lst
|
||||
return $ MalHashMap new_hm
|
||||
return $ MalHashMap new_hm m
|
||||
eval_ast ast env = return ast
|
||||
|
||||
let_bind :: Env -> [MalVal] -> IO Env
|
||||
@ -37,32 +37,29 @@ let_bind env (b:e:xs) = do
|
||||
let_bind env xs
|
||||
|
||||
apply_ast :: MalVal -> Env -> IO MalVal
|
||||
apply_ast ast@(MalList (MalSymbol "def!" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do
|
||||
case args of
|
||||
(a1@(MalSymbol _): a2 : []) -> do
|
||||
evaled <- eval a2 env
|
||||
env_set env a1 evaled
|
||||
_ -> error $ "invalid def!"
|
||||
apply_ast ast@(MalList (MalSymbol "let*" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do
|
||||
case args of
|
||||
(MalList a1 : a2 : []) -> do
|
||||
(a1 : a2 : []) -> do
|
||||
params <- (_to_list a1)
|
||||
let_env <- env_new $ Just env
|
||||
let_bind let_env a1
|
||||
eval a2 let_env
|
||||
(MalVector a1 : a2 : []) -> do
|
||||
let_env <- env_new $ Just env
|
||||
let_bind let_env a1
|
||||
let_bind let_env params
|
||||
eval a2 let_env
|
||||
_ -> error $ "invalid let*"
|
||||
apply_ast ast@(MalList (MalSymbol "do" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
|
||||
case args of
|
||||
([]) -> return Nil
|
||||
_ -> do
|
||||
el <- eval_ast (MalList args) env
|
||||
el <- eval_ast (MalList args Nil) env
|
||||
case el of
|
||||
(MalList el) -> return $ last el
|
||||
(MalList lst _) -> return $ last lst
|
||||
|
||||
apply_ast ast@(MalList (MalSymbol "if" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : a3 : []) -> do
|
||||
cond <- eval a1 env
|
||||
@ -75,23 +72,22 @@ apply_ast ast@(MalList (MalSymbol "if" : args)) env = do
|
||||
then return Nil
|
||||
else eval a2 env
|
||||
_ -> error $ "invalid if"
|
||||
apply_ast ast@(MalList (MalSymbol "fn*" : args)) env = do
|
||||
let params = case args of
|
||||
((MalList lst) : _) -> lst
|
||||
((MalVector lst) : _) -> lst in
|
||||
case args of
|
||||
(a1 : a2 : []) -> do
|
||||
return $ (_malfunc a2 env a1 (\args -> do
|
||||
fn_env1 <- env_new $ Just env
|
||||
fn_env2 <- (env_bind fn_env1 params args)
|
||||
eval a2 fn_env2))
|
||||
_ -> error $ "invalid fn*"
|
||||
apply_ast ast@(MalList _) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : []) -> do
|
||||
params <- (_to_list a1)
|
||||
return $ (_malfunc a2 env (MalList params Nil)
|
||||
(\args -> do
|
||||
fn_env1 <- env_new $ Just env
|
||||
fn_env2 <- (env_bind fn_env1 params args)
|
||||
eval a2 fn_env2))
|
||||
_ -> error $ "invalid fn*"
|
||||
apply_ast ast@(MalList _ _) env = do
|
||||
el <- eval_ast ast env
|
||||
case el of
|
||||
(MalList (Func (Fn f) : rest)) ->
|
||||
(MalList ((Func (Fn f) _) : rest) _) ->
|
||||
f $ rest
|
||||
(MalList (MalFunc {ast=ast, env=fn_env, params=(MalList params)} : rest)) -> do
|
||||
(MalList ((MalFunc {ast=ast, env=fn_env, params=(MalList params Nil)}) : rest) _) -> do
|
||||
fn_env1 <- env_new $ Just fn_env
|
||||
fn_env2 <- (env_bind fn_env1 params rest)
|
||||
eval ast fn_env2
|
||||
@ -101,7 +97,7 @@ apply_ast ast@(MalList _) env = do
|
||||
eval :: MalVal -> Env -> IO MalVal
|
||||
eval ast env = do
|
||||
case ast of
|
||||
(MalList lst) -> apply_ast ast env
|
||||
(MalList _ _) -> apply_ast ast env
|
||||
_ -> eval_ast ast env
|
||||
|
||||
|
||||
@ -138,14 +134,14 @@ main = do
|
||||
-- core.hs: defined using Haskell
|
||||
(mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns)
|
||||
env_set repl_env (MalSymbol "eval") (_func (\[ast] -> eval ast repl_env))
|
||||
env_set repl_env (MalSymbol "*ARGV*") (MalList [])
|
||||
env_set repl_env (MalSymbol "*ARGV*") (MalList [] Nil)
|
||||
|
||||
-- core.mal: defined using the language itself
|
||||
rep repl_env "(def! not (fn* (a) (if a false true)))"
|
||||
rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
|
||||
|
||||
if length args > 0 then do
|
||||
env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)))
|
||||
env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)) Nil)
|
||||
rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
|
||||
return ()
|
||||
else
|
||||
|
@ -16,38 +16,38 @@ mal_read :: String -> IO MalVal
|
||||
mal_read str = read_str str
|
||||
|
||||
-- eval
|
||||
is_pair (MalList x:xs) = True
|
||||
is_pair (MalVector x:xs) = True
|
||||
is_pair (MalList x _:xs) = True
|
||||
is_pair (MalVector x _:xs) = True
|
||||
is_pair _ = False
|
||||
|
||||
quasiquote :: MalVal -> MalVal
|
||||
quasiquote ast =
|
||||
case ast of
|
||||
(MalList (MalSymbol "unquote" : a1 : [])) -> a1
|
||||
(MalList (MalList (MalSymbol "splice-unquote" : a01 : []) : rest)) ->
|
||||
MalList [(MalSymbol "concat"), a01, quasiquote (MalList rest)]
|
||||
(MalVector (MalList (MalSymbol "splice-unquote" : a01 : []) : rest)) ->
|
||||
MalList [(MalSymbol "concat"), a01, quasiquote (MalVector rest)]
|
||||
(MalList (a0 : rest)) -> MalList [(MalSymbol "cons"),
|
||||
quasiquote a0,
|
||||
quasiquote (MalList rest)]
|
||||
(MalVector (a0 : rest)) -> MalList [(MalSymbol "cons"),
|
||||
(MalList (MalSymbol "unquote" : a1 : []) _) -> a1
|
||||
(MalList (MalList (MalSymbol "splice-unquote" : a01 : []) _ : rest) _) ->
|
||||
MalList [(MalSymbol "concat"), a01, quasiquote (MalList rest Nil)] Nil
|
||||
(MalVector (MalList (MalSymbol "splice-unquote" : a01 : []) _ : rest) _) ->
|
||||
MalList [(MalSymbol "concat"), a01, quasiquote (MalVector rest Nil)] Nil
|
||||
(MalList (a0 : rest) _) -> MalList [(MalSymbol "cons"),
|
||||
quasiquote a0,
|
||||
quasiquote (MalVector rest)]
|
||||
_ -> MalList [(MalSymbol "quote"), ast]
|
||||
quasiquote (MalList rest Nil)] Nil
|
||||
(MalVector (a0 : rest) _) -> MalList [(MalSymbol "cons"),
|
||||
quasiquote a0,
|
||||
quasiquote (MalVector rest Nil)] Nil
|
||||
_ -> MalList [(MalSymbol "quote"), ast] Nil
|
||||
|
||||
|
||||
eval_ast :: MalVal -> Env -> IO MalVal
|
||||
eval_ast sym@(MalSymbol _) env = env_get env sym
|
||||
eval_ast ast@(MalList lst) env = do
|
||||
eval_ast ast@(MalList lst m) env = do
|
||||
new_lst <- mapM (\x -> (eval x env)) lst
|
||||
return $ MalList new_lst
|
||||
eval_ast ast@(MalVector lst) env = do
|
||||
return $ MalList new_lst m
|
||||
eval_ast ast@(MalVector lst m) env = do
|
||||
new_lst <- mapM (\x -> (eval x env)) lst
|
||||
return $ MalVector new_lst
|
||||
eval_ast ast@(MalHashMap lst) env = do
|
||||
return $ MalVector new_lst m
|
||||
eval_ast ast@(MalHashMap lst m) env = do
|
||||
new_hm <- DT.mapM (\x -> (eval x env)) lst
|
||||
return $ MalHashMap new_hm
|
||||
return $ MalHashMap new_hm m
|
||||
eval_ast ast env = return ast
|
||||
|
||||
let_bind :: Env -> [MalVal] -> IO Env
|
||||
@ -58,40 +58,37 @@ let_bind env (b:e:xs) = do
|
||||
let_bind env xs
|
||||
|
||||
apply_ast :: MalVal -> Env -> IO MalVal
|
||||
apply_ast ast@(MalList (MalSymbol "def!" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do
|
||||
case args of
|
||||
(a1@(MalSymbol _): a2 : []) -> do
|
||||
evaled <- eval a2 env
|
||||
env_set env a1 evaled
|
||||
_ -> error $ "invalid def!"
|
||||
apply_ast ast@(MalList (MalSymbol "let*" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do
|
||||
case args of
|
||||
(MalList a1 : a2 : []) -> do
|
||||
(a1 : a2 : []) -> do
|
||||
params <- (_to_list a1)
|
||||
let_env <- env_new $ Just env
|
||||
let_bind let_env a1
|
||||
eval a2 let_env
|
||||
(MalVector a1 : a2 : []) -> do
|
||||
let_env <- env_new $ Just env
|
||||
let_bind let_env a1
|
||||
let_bind let_env params
|
||||
eval a2 let_env
|
||||
_ -> error $ "invalid let*"
|
||||
apply_ast ast@(MalList (MalSymbol "quote" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "quote" : args) _) env = do
|
||||
case args of
|
||||
a1 : [] -> return a1
|
||||
_ -> error $ "invalid quote"
|
||||
apply_ast ast@(MalList (MalSymbol "quasiquote" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do
|
||||
case args of
|
||||
a1 : [] -> eval (quasiquote a1) env
|
||||
_ -> error $ "invalid quasiquote"
|
||||
apply_ast ast@(MalList (MalSymbol "do" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
|
||||
case args of
|
||||
([]) -> return Nil
|
||||
_ -> do
|
||||
el <- eval_ast (MalList args) env
|
||||
el <- eval_ast (MalList args Nil) env
|
||||
case el of
|
||||
(MalList el) -> return $ last el
|
||||
(MalList lst _) -> return $ last lst
|
||||
|
||||
apply_ast ast@(MalList (MalSymbol "if" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : a3 : []) -> do
|
||||
cond <- eval a1 env
|
||||
@ -104,23 +101,22 @@ apply_ast ast@(MalList (MalSymbol "if" : args)) env = do
|
||||
then return Nil
|
||||
else eval a2 env
|
||||
_ -> error $ "invalid if"
|
||||
apply_ast ast@(MalList (MalSymbol "fn*" : args)) env = do
|
||||
let params = case args of
|
||||
((MalList lst) : _) -> lst
|
||||
((MalVector lst) : _) -> lst in
|
||||
case args of
|
||||
(a1 : a2 : []) -> do
|
||||
return $ (_malfunc a2 env a1 (\args -> do
|
||||
fn_env1 <- env_new $ Just env
|
||||
fn_env2 <- (env_bind fn_env1 params args)
|
||||
eval a2 fn_env2))
|
||||
_ -> error $ "invalid fn*"
|
||||
apply_ast ast@(MalList _) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : []) -> do
|
||||
params <- (_to_list a1)
|
||||
return $ (_malfunc a2 env (MalList params Nil)
|
||||
(\args -> do
|
||||
fn_env1 <- env_new $ Just env
|
||||
fn_env2 <- (env_bind fn_env1 params args)
|
||||
eval a2 fn_env2))
|
||||
_ -> error $ "invalid fn*"
|
||||
apply_ast ast@(MalList _ _) env = do
|
||||
el <- eval_ast ast env
|
||||
case el of
|
||||
(MalList (Func (Fn f) : rest)) ->
|
||||
(MalList ((Func (Fn f) _) : rest) _) ->
|
||||
f $ rest
|
||||
(MalList (MalFunc {ast=ast, env=fn_env, params=(MalList params)} : rest)) -> do
|
||||
(MalList ((MalFunc {ast=ast, env=fn_env, params=(MalList params Nil)}) : rest) _) -> do
|
||||
fn_env1 <- env_new $ Just fn_env
|
||||
fn_env2 <- (env_bind fn_env1 params rest)
|
||||
eval ast fn_env2
|
||||
@ -130,7 +126,7 @@ apply_ast ast@(MalList _) env = do
|
||||
eval :: MalVal -> Env -> IO MalVal
|
||||
eval ast env = do
|
||||
case ast of
|
||||
(MalList lst) -> apply_ast ast env
|
||||
(MalList _ _) -> apply_ast ast env
|
||||
_ -> eval_ast ast env
|
||||
|
||||
|
||||
@ -167,14 +163,14 @@ main = do
|
||||
-- core.hs: defined using Haskell
|
||||
(mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns)
|
||||
env_set repl_env (MalSymbol "eval") (_func (\[ast] -> eval ast repl_env))
|
||||
env_set repl_env (MalSymbol "*ARGV*") (MalList [])
|
||||
env_set repl_env (MalSymbol "*ARGV*") (MalList [] Nil)
|
||||
|
||||
-- core.mal: defined using the language itself
|
||||
rep repl_env "(def! not (fn* (a) (if a false true)))"
|
||||
rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
|
||||
|
||||
if length args > 0 then do
|
||||
env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)))
|
||||
env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)) Nil)
|
||||
rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
|
||||
return ()
|
||||
else
|
||||
|
@ -16,28 +16,28 @@ mal_read :: String -> IO MalVal
|
||||
mal_read str = read_str str
|
||||
|
||||
-- eval
|
||||
is_pair (MalList x:xs) = True
|
||||
is_pair (MalVector x:xs) = True
|
||||
is_pair (MalList x _:xs) = True
|
||||
is_pair (MalVector x _:xs) = True
|
||||
is_pair _ = False
|
||||
|
||||
quasiquote :: MalVal -> MalVal
|
||||
quasiquote ast =
|
||||
case ast of
|
||||
(MalList (MalSymbol "unquote" : a1 : [])) -> a1
|
||||
(MalList (MalList (MalSymbol "splice-unquote" : a01 : []) : rest)) ->
|
||||
MalList [(MalSymbol "concat"), a01, quasiquote (MalList rest)]
|
||||
(MalVector (MalList (MalSymbol "splice-unquote" : a01 : []) : rest)) ->
|
||||
MalList [(MalSymbol "concat"), a01, quasiquote (MalVector rest)]
|
||||
(MalList (a0 : rest)) -> MalList [(MalSymbol "cons"),
|
||||
quasiquote a0,
|
||||
quasiquote (MalList rest)]
|
||||
(MalVector (a0 : rest)) -> MalList [(MalSymbol "cons"),
|
||||
(MalList (MalSymbol "unquote" : a1 : []) _) -> a1
|
||||
(MalList (MalList (MalSymbol "splice-unquote" : a01 : []) _ : rest) _) ->
|
||||
MalList [(MalSymbol "concat"), a01, quasiquote (MalList rest Nil)] Nil
|
||||
(MalVector (MalList (MalSymbol "splice-unquote" : a01 : []) _ : rest) _) ->
|
||||
MalList [(MalSymbol "concat"), a01, quasiquote (MalVector rest Nil)] Nil
|
||||
(MalList (a0 : rest) _) -> MalList [(MalSymbol "cons"),
|
||||
quasiquote a0,
|
||||
quasiquote (MalVector rest)]
|
||||
_ -> MalList [(MalSymbol "quote"), ast]
|
||||
quasiquote (MalList rest Nil)] Nil
|
||||
(MalVector (a0 : rest) _) -> MalList [(MalSymbol "cons"),
|
||||
quasiquote a0,
|
||||
quasiquote (MalVector rest Nil)] Nil
|
||||
_ -> MalList [(MalSymbol "quote"), ast] Nil
|
||||
|
||||
is_macro_call :: MalVal -> Env -> IO Bool
|
||||
is_macro_call (MalList (a0@(MalSymbol _) : rest)) env = do
|
||||
is_macro_call (MalList (a0@(MalSymbol _) : rest) _) env = do
|
||||
e <- env_find env a0
|
||||
case e of
|
||||
Just e -> do
|
||||
@ -49,7 +49,7 @@ is_macro_call (MalList (a0@(MalSymbol _) : rest)) env = do
|
||||
is_macro_call _ _ = return False
|
||||
|
||||
macroexpand :: MalVal -> Env -> IO MalVal
|
||||
macroexpand ast@(MalList (a0 : args)) env = do
|
||||
macroexpand ast@(MalList (a0 : args) _) env = do
|
||||
mc <- is_macro_call ast env
|
||||
if mc then do
|
||||
mac <- env_get env a0
|
||||
@ -66,15 +66,15 @@ macroexpand ast _ = return ast
|
||||
|
||||
eval_ast :: MalVal -> Env -> IO MalVal
|
||||
eval_ast sym@(MalSymbol _) env = env_get env sym
|
||||
eval_ast ast@(MalList lst) env = do
|
||||
eval_ast ast@(MalList lst m) env = do
|
||||
new_lst <- mapM (\x -> (eval x env)) lst
|
||||
return $ MalList new_lst
|
||||
eval_ast ast@(MalVector lst) env = do
|
||||
return $ MalList new_lst m
|
||||
eval_ast ast@(MalVector lst m) env = do
|
||||
new_lst <- mapM (\x -> (eval x env)) lst
|
||||
return $ MalVector new_lst
|
||||
eval_ast ast@(MalHashMap lst) env = do
|
||||
return $ MalVector new_lst m
|
||||
eval_ast ast@(MalHashMap lst m) env = do
|
||||
new_hm <- DT.mapM (\x -> (eval x env)) lst
|
||||
return $ MalHashMap new_hm
|
||||
return $ MalHashMap new_hm m
|
||||
eval_ast ast env = return ast
|
||||
|
||||
let_bind :: Env -> [MalVal] -> IO Env
|
||||
@ -85,56 +85,54 @@ let_bind env (b:e:xs) = do
|
||||
let_bind env xs
|
||||
|
||||
apply_ast :: MalVal -> Env -> IO MalVal
|
||||
apply_ast ast@(MalList (MalSymbol "def!" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do
|
||||
case args of
|
||||
(a1@(MalSymbol _): a2 : []) -> do
|
||||
evaled <- eval a2 env
|
||||
env_set env a1 evaled
|
||||
_ -> error $ "invalid def!"
|
||||
apply_ast ast@(MalList (MalSymbol "let*" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do
|
||||
case args of
|
||||
(MalList a1 : a2 : []) -> do
|
||||
(a1 : a2 : []) -> do
|
||||
params <- (_to_list a1)
|
||||
let_env <- env_new $ Just env
|
||||
let_bind let_env a1
|
||||
eval a2 let_env
|
||||
(MalVector a1 : a2 : []) -> do
|
||||
let_env <- env_new $ Just env
|
||||
let_bind let_env a1
|
||||
let_bind let_env params
|
||||
eval a2 let_env
|
||||
_ -> error $ "invalid let*"
|
||||
apply_ast ast@(MalList (MalSymbol "quote" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "quote" : args) _) env = do
|
||||
case args of
|
||||
a1 : [] -> return a1
|
||||
_ -> error $ "invalid quote"
|
||||
apply_ast ast@(MalList (MalSymbol "quasiquote" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do
|
||||
case args of
|
||||
a1 : [] -> eval (quasiquote a1) env
|
||||
_ -> error $ "invalid quasiquote"
|
||||
|
||||
apply_ast ast@(MalList (MalSymbol "defmacro!" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : []) -> do
|
||||
func <- eval a2 env
|
||||
case func of
|
||||
MalFunc {fn=f, ast=a, env=e, params=p} -> do
|
||||
let new_func = MalFunc {fn=f, ast=a, env=e,
|
||||
params=p, macro=True} in
|
||||
params=p, macro=True,
|
||||
meta=Nil} in
|
||||
env_set env a1 new_func
|
||||
_ -> error $ "defmacro! on non-function"
|
||||
_ -> error $ "invalid defmacro!"
|
||||
apply_ast ast@(MalList (MalSymbol "macroexpand" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "macroexpand" : args) _) env = do
|
||||
case args of
|
||||
(a1 : []) -> macroexpand a1 env
|
||||
_ -> error $ "invalid macroexpand"
|
||||
apply_ast ast@(MalList (MalSymbol "do" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
|
||||
case args of
|
||||
([]) -> return Nil
|
||||
_ -> do
|
||||
el <- eval_ast (MalList args) env
|
||||
el <- eval_ast (MalList args Nil) env
|
||||
case el of
|
||||
(MalList el) -> return $ last el
|
||||
(MalList lst _) -> return $ last lst
|
||||
|
||||
apply_ast ast@(MalList (MalSymbol "if" : args)) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : a3 : []) -> do
|
||||
cond <- eval a1 env
|
||||
@ -147,32 +145,31 @@ apply_ast ast@(MalList (MalSymbol "if" : args)) env = do
|
||||
then return Nil
|
||||
else eval a2 env
|
||||
_ -> error $ "invalid if"
|
||||
apply_ast ast@(MalList (MalSymbol "fn*" : args)) env = do
|
||||
let params = case args of
|
||||
((MalList lst) : _) -> lst
|
||||
((MalVector lst) : _) -> lst in
|
||||
case args of
|
||||
(a1 : a2 : []) -> do
|
||||
return $ (_malfunc a2 env a1 (\args -> do
|
||||
fn_env1 <- env_new $ Just env
|
||||
fn_env2 <- (env_bind fn_env1 params args)
|
||||
eval a2 fn_env2))
|
||||
_ -> error $ "invalid fn*"
|
||||
apply_ast ast@(MalList _) env = do
|
||||
apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : []) -> do
|
||||
params <- (_to_list a1)
|
||||
return $ (_malfunc a2 env (MalList params Nil)
|
||||
(\args -> do
|
||||
fn_env1 <- env_new $ Just env
|
||||
fn_env2 <- (env_bind fn_env1 params args)
|
||||
eval a2 fn_env2))
|
||||
_ -> error $ "invalid fn*"
|
||||
apply_ast ast@(MalList _ _) env = do
|
||||
mc <- is_macro_call ast env
|
||||
if mc then do
|
||||
new_ast <- macroexpand ast env
|
||||
eval new_ast env
|
||||
else
|
||||
case ast of
|
||||
MalList _ -> do
|
||||
MalList _ _ -> do
|
||||
el <- eval_ast ast env
|
||||
case el of
|
||||
(MalList (Func (Fn f) : rest)) ->
|
||||
(MalList ((Func (Fn f) _) : rest) _) ->
|
||||
f $ rest
|
||||
(MalList (MalFunc {ast=ast,
|
||||
env=fn_env,
|
||||
params=(MalList params)} : rest)) -> do
|
||||
(MalList ((MalFunc {ast=ast,
|
||||
env=fn_env,
|
||||
params=(MalList params Nil)} : rest)) _) -> do
|
||||
fn_env1 <- env_new $ Just fn_env
|
||||
fn_env2 <- (env_bind fn_env1 params rest)
|
||||
eval ast fn_env2
|
||||
@ -183,7 +180,7 @@ apply_ast ast@(MalList _) env = do
|
||||
eval :: MalVal -> Env -> IO MalVal
|
||||
eval ast env = do
|
||||
case ast of
|
||||
(MalList lst) -> apply_ast ast env
|
||||
(MalList _ _) -> apply_ast ast env
|
||||
_ -> eval_ast ast env
|
||||
|
||||
|
||||
@ -220,7 +217,7 @@ main = do
|
||||
-- core.hs: defined using Haskell
|
||||
(mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns)
|
||||
env_set repl_env (MalSymbol "eval") (_func (\[ast] -> eval ast repl_env))
|
||||
env_set repl_env (MalSymbol "*ARGV*") (MalList [])
|
||||
env_set repl_env (MalSymbol "*ARGV*") (MalList [] Nil)
|
||||
|
||||
-- core.mal: defined using the language itself
|
||||
rep repl_env "(def! not (fn* (a) (if a false true)))"
|
||||
@ -229,7 +226,7 @@ main = do
|
||||
rep repl_env "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))"
|
||||
|
||||
if length args > 0 then do
|
||||
env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)))
|
||||
env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)) Nil)
|
||||
rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
|
||||
return ()
|
||||
else
|
||||
|
233
haskell/step9_try.hs
Normal file
233
haskell/step9_try.hs
Normal file
@ -0,0 +1,233 @@
|
||||
import System.Environment (getArgs)
|
||||
import Control.Monad (when, mapM)
|
||||
import Control.Monad.Error (throwError)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Traversable as DT
|
||||
|
||||
import Readline (readline, load_history)
|
||||
import Types
|
||||
import Reader (read_str)
|
||||
import Printer (_pr_str)
|
||||
import Env (Env, env_new, env_bind, env_find, env_get, env_set)
|
||||
import Core as Core
|
||||
|
||||
-- read
|
||||
mal_read :: String -> IO MalVal
|
||||
mal_read str = read_str str
|
||||
|
||||
-- eval
|
||||
is_pair (MalList x _:xs) = True
|
||||
is_pair (MalVector x _:xs) = True
|
||||
is_pair _ = False
|
||||
|
||||
quasiquote :: MalVal -> MalVal
|
||||
quasiquote ast =
|
||||
case ast of
|
||||
(MalList (MalSymbol "unquote" : a1 : []) _) -> a1
|
||||
(MalList (MalList (MalSymbol "splice-unquote" : a01 : []) _ : rest) _) ->
|
||||
MalList [(MalSymbol "concat"), a01, quasiquote (MalList rest Nil)] Nil
|
||||
(MalVector (MalList (MalSymbol "splice-unquote" : a01 : []) _ : rest) _) ->
|
||||
MalList [(MalSymbol "concat"), a01, quasiquote (MalVector rest Nil)] Nil
|
||||
(MalList (a0 : rest) _) -> MalList [(MalSymbol "cons"),
|
||||
quasiquote a0,
|
||||
quasiquote (MalList rest Nil)] Nil
|
||||
(MalVector (a0 : rest) _) -> MalList [(MalSymbol "cons"),
|
||||
quasiquote a0,
|
||||
quasiquote (MalVector rest Nil)] Nil
|
||||
_ -> MalList [(MalSymbol "quote"), ast] Nil
|
||||
|
||||
is_macro_call :: MalVal -> Env -> IO Bool
|
||||
is_macro_call (MalList (a0@(MalSymbol _) : rest) _) env = do
|
||||
e <- env_find env a0
|
||||
case e of
|
||||
Just e -> do
|
||||
f <- env_get e a0
|
||||
case f of
|
||||
MalFunc {macro=True} -> return True
|
||||
_ -> return False
|
||||
Nothing -> return False
|
||||
is_macro_call _ _ = return False
|
||||
|
||||
macroexpand :: MalVal -> Env -> IO MalVal
|
||||
macroexpand ast@(MalList (a0 : args) _) env = do
|
||||
mc <- is_macro_call ast env
|
||||
if mc then do
|
||||
mac <- env_get env a0
|
||||
case mac of
|
||||
MalFunc {fn=(Fn f)} -> do
|
||||
new_ast <- f args
|
||||
macroexpand new_ast env
|
||||
_ ->
|
||||
return ast
|
||||
else
|
||||
return ast
|
||||
macroexpand ast _ = return ast
|
||||
|
||||
|
||||
eval_ast :: MalVal -> Env -> IO MalVal
|
||||
eval_ast sym@(MalSymbol _) env = env_get env sym
|
||||
eval_ast ast@(MalList lst m) env = do
|
||||
new_lst <- mapM (\x -> (eval x env)) lst
|
||||
return $ MalList new_lst m
|
||||
eval_ast ast@(MalVector lst m) env = do
|
||||
new_lst <- mapM (\x -> (eval x env)) lst
|
||||
return $ MalVector new_lst m
|
||||
eval_ast ast@(MalHashMap lst m) env = do
|
||||
new_hm <- DT.mapM (\x -> (eval x env)) lst
|
||||
return $ MalHashMap new_hm m
|
||||
eval_ast ast env = return ast
|
||||
|
||||
let_bind :: Env -> [MalVal] -> IO Env
|
||||
let_bind env [] = return env
|
||||
let_bind env (b:e:xs) = do
|
||||
evaled <- eval e env
|
||||
x <- env_set env b evaled
|
||||
let_bind env xs
|
||||
|
||||
apply_ast :: MalVal -> Env -> IO MalVal
|
||||
apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do
|
||||
case args of
|
||||
(a1@(MalSymbol _): a2 : []) -> do
|
||||
evaled <- eval a2 env
|
||||
env_set env a1 evaled
|
||||
_ -> error $ "invalid def!"
|
||||
apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : []) -> do
|
||||
params <- (_to_list a1)
|
||||
let_env <- env_new $ Just env
|
||||
let_bind let_env params
|
||||
eval a2 let_env
|
||||
_ -> error $ "invalid let*"
|
||||
apply_ast ast@(MalList (MalSymbol "quote" : args) _) env = do
|
||||
case args of
|
||||
a1 : [] -> return a1
|
||||
_ -> error $ "invalid quote"
|
||||
apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do
|
||||
case args of
|
||||
a1 : [] -> eval (quasiquote a1) env
|
||||
_ -> error $ "invalid quasiquote"
|
||||
|
||||
apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : []) -> do
|
||||
func <- eval a2 env
|
||||
case func of
|
||||
MalFunc {fn=f, ast=a, env=e, params=p} -> do
|
||||
let new_func = MalFunc {fn=f, ast=a, env=e,
|
||||
params=p, macro=True,
|
||||
meta=Nil} in
|
||||
env_set env a1 new_func
|
||||
_ -> error $ "defmacro! on non-function"
|
||||
_ -> error $ "invalid defmacro!"
|
||||
apply_ast ast@(MalList (MalSymbol "macroexpand" : args) _) env = do
|
||||
case args of
|
||||
(a1 : []) -> macroexpand a1 env
|
||||
_ -> error $ "invalid macroexpand"
|
||||
apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
|
||||
case args of
|
||||
([]) -> return Nil
|
||||
_ -> do
|
||||
el <- eval_ast (MalList args Nil) env
|
||||
case el of
|
||||
(MalList lst _) -> return $ last lst
|
||||
|
||||
apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : a3 : []) -> do
|
||||
cond <- eval a1 env
|
||||
if cond == MalFalse || cond == Nil
|
||||
then eval a3 env
|
||||
else eval a2 env
|
||||
(a1 : a2 : []) -> do
|
||||
cond <- eval a1 env
|
||||
if cond == MalFalse || cond == Nil
|
||||
then return Nil
|
||||
else eval a2 env
|
||||
_ -> error $ "invalid if"
|
||||
apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : []) -> do
|
||||
params <- (_to_list a1)
|
||||
return $ (_malfunc a2 env (MalList params Nil)
|
||||
(\args -> do
|
||||
fn_env1 <- env_new $ Just env
|
||||
fn_env2 <- (env_bind fn_env1 params args)
|
||||
eval a2 fn_env2))
|
||||
_ -> error $ "invalid fn*"
|
||||
apply_ast ast@(MalList _ _) env = do
|
||||
mc <- is_macro_call ast env
|
||||
if mc then do
|
||||
new_ast <- macroexpand ast env
|
||||
eval new_ast env
|
||||
else
|
||||
case ast of
|
||||
MalList _ _ -> do
|
||||
el <- eval_ast ast env
|
||||
case el of
|
||||
(MalList ((Func (Fn f) _) : rest) _) ->
|
||||
f $ rest
|
||||
(MalList ((MalFunc {ast=ast,
|
||||
env=fn_env,
|
||||
params=(MalList params Nil)} : rest)) _) -> do
|
||||
fn_env1 <- env_new $ Just fn_env
|
||||
fn_env2 <- (env_bind fn_env1 params rest)
|
||||
eval ast fn_env2
|
||||
el ->
|
||||
error $ "invalid apply: " ++ (show el)
|
||||
_ -> return ast
|
||||
|
||||
eval :: MalVal -> Env -> IO MalVal
|
||||
eval ast env = do
|
||||
case ast of
|
||||
(MalList _ _) -> apply_ast ast env
|
||||
_ -> eval_ast ast env
|
||||
|
||||
|
||||
-- print
|
||||
mal_print :: MalVal -> String
|
||||
mal_print exp = show exp
|
||||
|
||||
-- repl
|
||||
|
||||
rep :: Env -> String -> IO String
|
||||
rep env line = do
|
||||
ast <- mal_read line
|
||||
exp <- eval ast env
|
||||
return $ mal_print exp
|
||||
|
||||
repl_loop :: Env -> IO ()
|
||||
repl_loop env = do
|
||||
line <- readline "user> "
|
||||
case line of
|
||||
Nothing -> return ()
|
||||
Just "" -> repl_loop env
|
||||
Just str -> do
|
||||
out <- catchAny (rep env str) $ \e -> do
|
||||
return $ "Error: " ++ (show e)
|
||||
putStrLn out
|
||||
repl_loop env
|
||||
|
||||
main = do
|
||||
args <- getArgs
|
||||
load_history
|
||||
|
||||
repl_env <- env_new Nothing
|
||||
|
||||
-- core.hs: defined using Haskell
|
||||
(mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns)
|
||||
env_set repl_env (MalSymbol "eval") (_func (\[ast] -> eval ast repl_env))
|
||||
env_set repl_env (MalSymbol "*ARGV*") (MalList [] Nil)
|
||||
|
||||
-- core.mal: defined using the language itself
|
||||
rep repl_env "(def! not (fn* (a) (if a false true)))"
|
||||
rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
|
||||
rep repl_env "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))"
|
||||
rep repl_env "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))"
|
||||
|
||||
if length args > 0 then do
|
||||
env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)) Nil)
|
||||
rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
|
||||
return ()
|
||||
else
|
||||
repl_loop repl_env
|
235
haskell/stepA_interop.hs
Normal file
235
haskell/stepA_interop.hs
Normal file
@ -0,0 +1,235 @@
|
||||
import System.Environment (getArgs)
|
||||
import Control.Monad (when, mapM)
|
||||
import Control.Monad.Error (throwError)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Traversable as DT
|
||||
|
||||
import Readline (readline, load_history)
|
||||
import Types
|
||||
import Reader (read_str)
|
||||
import Printer (_pr_str)
|
||||
import Env (Env, env_new, env_bind, env_find, env_get, env_set)
|
||||
import Core as Core
|
||||
|
||||
-- read
|
||||
mal_read :: String -> IO MalVal
|
||||
mal_read str = read_str str
|
||||
|
||||
-- eval
|
||||
is_pair (MalList x _:xs) = True
|
||||
is_pair (MalVector x _:xs) = True
|
||||
is_pair _ = False
|
||||
|
||||
quasiquote :: MalVal -> MalVal
|
||||
quasiquote ast =
|
||||
case ast of
|
||||
(MalList (MalSymbol "unquote" : a1 : []) _) -> a1
|
||||
(MalList (MalList (MalSymbol "splice-unquote" : a01 : []) _ : rest) _) ->
|
||||
MalList [(MalSymbol "concat"), a01, quasiquote (MalList rest Nil)] Nil
|
||||
(MalVector (MalList (MalSymbol "splice-unquote" : a01 : []) _ : rest) _) ->
|
||||
MalList [(MalSymbol "concat"), a01, quasiquote (MalVector rest Nil)] Nil
|
||||
(MalList (a0 : rest) _) -> MalList [(MalSymbol "cons"),
|
||||
quasiquote a0,
|
||||
quasiquote (MalList rest Nil)] Nil
|
||||
(MalVector (a0 : rest) _) -> MalList [(MalSymbol "cons"),
|
||||
quasiquote a0,
|
||||
quasiquote (MalVector rest Nil)] Nil
|
||||
_ -> MalList [(MalSymbol "quote"), ast] Nil
|
||||
|
||||
is_macro_call :: MalVal -> Env -> IO Bool
|
||||
is_macro_call (MalList (a0@(MalSymbol _) : rest) _) env = do
|
||||
e <- env_find env a0
|
||||
case e of
|
||||
Just e -> do
|
||||
f <- env_get e a0
|
||||
case f of
|
||||
MalFunc {macro=True} -> return True
|
||||
_ -> return False
|
||||
Nothing -> return False
|
||||
is_macro_call _ _ = return False
|
||||
|
||||
macroexpand :: MalVal -> Env -> IO MalVal
|
||||
macroexpand ast@(MalList (a0 : args) _) env = do
|
||||
mc <- is_macro_call ast env
|
||||
if mc then do
|
||||
mac <- env_get env a0
|
||||
case mac of
|
||||
MalFunc {fn=(Fn f)} -> do
|
||||
new_ast <- f args
|
||||
macroexpand new_ast env
|
||||
_ ->
|
||||
return ast
|
||||
else
|
||||
return ast
|
||||
macroexpand ast _ = return ast
|
||||
|
||||
|
||||
eval_ast :: MalVal -> Env -> IO MalVal
|
||||
eval_ast sym@(MalSymbol _) env = env_get env sym
|
||||
eval_ast ast@(MalList lst m) env = do
|
||||
new_lst <- mapM (\x -> (eval x env)) lst
|
||||
return $ MalList new_lst m
|
||||
eval_ast ast@(MalVector lst m) env = do
|
||||
new_lst <- mapM (\x -> (eval x env)) lst
|
||||
return $ MalVector new_lst m
|
||||
eval_ast ast@(MalHashMap lst m) env = do
|
||||
new_hm <- DT.mapM (\x -> (eval x env)) lst
|
||||
return $ MalHashMap new_hm m
|
||||
eval_ast ast env = return ast
|
||||
|
||||
let_bind :: Env -> [MalVal] -> IO Env
|
||||
let_bind env [] = return env
|
||||
let_bind env (b:e:xs) = do
|
||||
evaled <- eval e env
|
||||
x <- env_set env b evaled
|
||||
let_bind env xs
|
||||
|
||||
apply_ast :: MalVal -> Env -> IO MalVal
|
||||
apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do
|
||||
case args of
|
||||
(a1@(MalSymbol _): a2 : []) -> do
|
||||
evaled <- eval a2 env
|
||||
env_set env a1 evaled
|
||||
_ -> error $ "invalid def!"
|
||||
apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : []) -> do
|
||||
params <- (_to_list a1)
|
||||
let_env <- env_new $ Just env
|
||||
let_bind let_env params
|
||||
eval a2 let_env
|
||||
_ -> error $ "invalid let*"
|
||||
apply_ast ast@(MalList (MalSymbol "quote" : args) _) env = do
|
||||
case args of
|
||||
a1 : [] -> return a1
|
||||
_ -> error $ "invalid quote"
|
||||
apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do
|
||||
case args of
|
||||
a1 : [] -> eval (quasiquote a1) env
|
||||
_ -> error $ "invalid quasiquote"
|
||||
|
||||
apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : []) -> do
|
||||
func <- eval a2 env
|
||||
case func of
|
||||
MalFunc {fn=f, ast=a, env=e, params=p} -> do
|
||||
let new_func = MalFunc {fn=f, ast=a, env=e,
|
||||
params=p, macro=True,
|
||||
meta=Nil} in
|
||||
env_set env a1 new_func
|
||||
_ -> error $ "defmacro! on non-function"
|
||||
_ -> error $ "invalid defmacro!"
|
||||
apply_ast ast@(MalList (MalSymbol "macroexpand" : args) _) env = do
|
||||
case args of
|
||||
(a1 : []) -> macroexpand a1 env
|
||||
_ -> error $ "invalid macroexpand"
|
||||
apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
|
||||
case args of
|
||||
([]) -> return Nil
|
||||
_ -> do
|
||||
el <- eval_ast (MalList args Nil) env
|
||||
case el of
|
||||
(MalList lst _) -> return $ last lst
|
||||
|
||||
apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : a3 : []) -> do
|
||||
cond <- eval a1 env
|
||||
if cond == MalFalse || cond == Nil
|
||||
then eval a3 env
|
||||
else eval a2 env
|
||||
(a1 : a2 : []) -> do
|
||||
cond <- eval a1 env
|
||||
if cond == MalFalse || cond == Nil
|
||||
then return Nil
|
||||
else eval a2 env
|
||||
_ -> error $ "invalid if"
|
||||
apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : []) -> do
|
||||
params <- (_to_list a1)
|
||||
return $ (_malfunc a2 env (MalList params Nil)
|
||||
(\args -> do
|
||||
fn_env1 <- env_new $ Just env
|
||||
fn_env2 <- (env_bind fn_env1 params args)
|
||||
eval a2 fn_env2))
|
||||
_ -> error $ "invalid fn*"
|
||||
apply_ast ast@(MalList _ _) env = do
|
||||
mc <- is_macro_call ast env
|
||||
if mc then do
|
||||
new_ast <- macroexpand ast env
|
||||
eval new_ast env
|
||||
else
|
||||
case ast of
|
||||
MalList _ _ -> do
|
||||
el <- eval_ast ast env
|
||||
case el of
|
||||
(MalList ((Func (Fn f) _) : rest) _) ->
|
||||
f $ rest
|
||||
(MalList ((MalFunc {ast=ast,
|
||||
env=fn_env,
|
||||
params=(MalList params Nil)} : rest)) _) -> do
|
||||
fn_env1 <- env_new $ Just fn_env
|
||||
fn_env2 <- (env_bind fn_env1 params rest)
|
||||
eval ast fn_env2
|
||||
el ->
|
||||
error $ "invalid apply: " ++ (show el)
|
||||
_ -> return ast
|
||||
|
||||
eval :: MalVal -> Env -> IO MalVal
|
||||
eval ast env = do
|
||||
case ast of
|
||||
(MalList _ _) -> apply_ast ast env
|
||||
_ -> eval_ast ast env
|
||||
|
||||
|
||||
-- print
|
||||
mal_print :: MalVal -> String
|
||||
mal_print exp = show exp
|
||||
|
||||
-- repl
|
||||
|
||||
rep :: Env -> String -> IO String
|
||||
rep env line = do
|
||||
ast <- mal_read line
|
||||
exp <- eval ast env
|
||||
return $ mal_print exp
|
||||
|
||||
repl_loop :: Env -> IO ()
|
||||
repl_loop env = do
|
||||
line <- readline "user> "
|
||||
case line of
|
||||
Nothing -> return ()
|
||||
Just "" -> repl_loop env
|
||||
Just str -> do
|
||||
out <- catchAny (rep env str) $ \e -> do
|
||||
return $ "Error: " ++ (show e)
|
||||
putStrLn out
|
||||
repl_loop env
|
||||
|
||||
main = do
|
||||
args <- getArgs
|
||||
load_history
|
||||
|
||||
repl_env <- env_new Nothing
|
||||
|
||||
-- core.hs: defined using Haskell
|
||||
(mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns)
|
||||
env_set repl_env (MalSymbol "eval") (_func (\[ast] -> eval ast repl_env))
|
||||
env_set repl_env (MalSymbol "*ARGV*") (MalList [] Nil)
|
||||
|
||||
-- core.mal: defined using the language itself
|
||||
rep repl_env "(def! *host-language* \"haskell\")"
|
||||
rep repl_env "(def! not (fn* (a) (if a false true)))"
|
||||
rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
|
||||
rep repl_env "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))"
|
||||
rep repl_env "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))"
|
||||
|
||||
if length args > 0 then do
|
||||
env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)) Nil)
|
||||
rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
|
||||
return ()
|
||||
else do
|
||||
rep repl_env "(println (str \"Mal [\" *host-language* \"]\"))"
|
||||
repl_loop repl_env
|
@ -21,6 +21,7 @@
|
||||
(inc3 9)
|
||||
;=>12
|
||||
|
||||
;;; TODO: really a step5 test
|
||||
;;
|
||||
;; Testing that (do (do)) not broken by TCO
|
||||
(do (do 1 2))
|
||||
@ -36,6 +37,7 @@
|
||||
;;
|
||||
;; -------- Optional Functionality --------
|
||||
|
||||
;; Testing comments in a file
|
||||
(load-file "../tests/incB.mal")
|
||||
; "incB.mal finished"
|
||||
;=>"incB.mal return string"
|
||||
@ -43,3 +45,13 @@
|
||||
;=>11
|
||||
(inc5 7)
|
||||
;=>12
|
||||
|
||||
;;; TODO: really a step5 test
|
||||
;; Testing that vector params not broken by TCO
|
||||
(def! g (fn* [] 78))
|
||||
(g)
|
||||
;=>78
|
||||
(def! g (fn* [a] (+ a 78)))
|
||||
(g 3)
|
||||
;=>81
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user