mirror of
https://github.com/kanaka/mal.git
synced 2024-09-19 01:28:26 +03:00
haskell: silent GHC warnings
Make all patterns exhaustive, report more invalid calls. Change some types in order to simplify the code: - String instead of MalVal for Env keys - IOThrows instead of IO for env_bind, env_set and let_bind. Use record syntactic sugar for MalFunc instead of hand-written constructor. Remove unused env component, instead use the fn component when the function is executed. Give a type signature to each function. Fix error reporting for invalid reset!. Avoid name clashes.
This commit is contained in:
Nicolas Boulenguez
parent
608a88851b
commit
b091e9541d
140
haskell/Core.hs
140
haskell/Core.hs
@ -3,19 +3,20 @@ module Core
|
||||
where
|
||||
|
||||
import System.IO (hFlush, stdout)
|
||||
import Control.Exception (catch)
|
||||
import Control.Monad.Trans (liftIO)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Foldable (foldlM)
|
||||
import Data.Time.Clock.POSIX (getPOSIXTime)
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
||||
import Data.IORef (newIORef, readIORef, writeIORef)
|
||||
|
||||
import Readline (readline)
|
||||
import Reader (read_str)
|
||||
import Types
|
||||
import Printer (_pr_str, _pr_list)
|
||||
import Printer (_pr_list)
|
||||
|
||||
-- General functions
|
||||
|
||||
equal_Q :: [MalVal] -> IOThrows MalVal
|
||||
equal_Q [a, b] = return $ if a == b then MalTrue else MalFalse
|
||||
equal_Q _ = throwStr "illegal arguments to ="
|
||||
|
||||
@ -23,65 +24,77 @@ 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 :: [MalVal] -> IOThrows MalVal
|
||||
throw (mv:[]) = throwMalVal mv
|
||||
throw _ = throwStr "illegal arguments to throw"
|
||||
|
||||
-- Scalar functions
|
||||
|
||||
symbol (MalString str:[]) = return $ MalSymbol str
|
||||
symbol :: [MalVal] -> IOThrows MalVal
|
||||
symbol [MalString s] = return $ MalSymbol s
|
||||
symbol _ = throwStr "symbol called with non-string"
|
||||
|
||||
keyword (MalString ('\x029e':str):[]) = return $ MalString $ "\x029e" ++ str
|
||||
keyword (MalString str:[]) = return $ MalString $ "\x029e" ++ str
|
||||
keyword :: [MalVal] -> IOThrows MalVal
|
||||
keyword [k@(MalString ('\x029e' : _))] = return k
|
||||
keyword [MalString s] = return $ MalString $ '\x029e' : s
|
||||
keyword _ = throwStr "keyword called with non-string"
|
||||
|
||||
|
||||
-- String functions
|
||||
|
||||
pr_str :: [MalVal] -> IOThrows MalVal
|
||||
pr_str args = do
|
||||
return $ MalString $ _pr_list True " " args
|
||||
|
||||
str :: [MalVal] -> IOThrows MalVal
|
||||
str args = do
|
||||
return $ MalString $ _pr_list False "" args
|
||||
|
||||
prn :: [MalVal] -> IOThrows MalVal
|
||||
prn args = do
|
||||
liftIO $ putStrLn $ _pr_list True " " args
|
||||
liftIO $ hFlush stdout
|
||||
return Nil
|
||||
|
||||
println :: [MalVal] -> IOThrows MalVal
|
||||
println args = do
|
||||
liftIO $ putStrLn $ _pr_list False " " args
|
||||
liftIO $ hFlush stdout
|
||||
return Nil
|
||||
|
||||
slurp :: [MalVal] -> IOThrows MalVal
|
||||
slurp ([MalString path]) = do
|
||||
str <- liftIO $ readFile path
|
||||
return $ MalString str
|
||||
contents <- liftIO $ readFile path
|
||||
return $ MalString contents
|
||||
slurp _ = throwStr "invalid arguments to slurp"
|
||||
|
||||
do_readline :: [MalVal] -> IOThrows MalVal
|
||||
do_readline ([MalString prompt]) = do
|
||||
str <- liftIO $ readline prompt
|
||||
case str of
|
||||
maybeLine <- liftIO $ readline prompt
|
||||
case maybeLine of
|
||||
Nothing -> throwStr "readline failed"
|
||||
Just str -> return $ MalString str
|
||||
Just line -> return $ MalString line
|
||||
do_readline _ = throwStr "invalid arguments to readline"
|
||||
|
||||
read_string :: [MalVal] -> IOThrows MalVal
|
||||
read_string [MalString s] = read_str s
|
||||
read_string _ = throwStr "invalid read-string"
|
||||
|
||||
-- Numeric functions
|
||||
|
||||
num_op :: (Int -> Int -> Int) -> [MalVal] -> IOThrows MalVal
|
||||
num_op op [MalNumber a, MalNumber b] = do
|
||||
return $ MalNumber $ op a b
|
||||
num_op _ _ = throwStr "illegal arguments to number operation"
|
||||
|
||||
cmp_op :: (Int -> Int -> Bool) -> [MalVal] -> IOThrows MalVal
|
||||
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 :: [MalVal] -> IOThrows MalVal
|
||||
time_ms _ = do
|
||||
t <- liftIO $ getPOSIXTime
|
||||
return $ MalNumber $ round (t * 1000)
|
||||
@ -89,51 +102,63 @@ time_ms _ = do
|
||||
|
||||
-- List functions
|
||||
|
||||
list :: [MalVal] -> IOThrows MalVal
|
||||
list args = return $ MalList args Nil
|
||||
|
||||
-- Vector functions
|
||||
|
||||
vector :: [MalVal] -> IOThrows MalVal
|
||||
vector args = return $ MalVector args Nil
|
||||
|
||||
-- Hash Map functions
|
||||
|
||||
_pairup [x] = throwStr "Odd number of elements to _pairup"
|
||||
_pairup :: [MalVal] -> IOThrows [(String, MalVal)]
|
||||
_pairup [] = return []
|
||||
_pairup (MalString x:y:xs) = do
|
||||
rest <- _pairup xs
|
||||
return $ (x,y):rest
|
||||
pairs <- _pairup xs
|
||||
return $ (x,y):pairs
|
||||
_pairup _ = throwStr "invalid hash-map or assoc"
|
||||
|
||||
hash_map :: [MalVal] -> IOThrows MalVal
|
||||
hash_map args = do
|
||||
pairs <- _pairup args
|
||||
return $ MalHashMap (Map.fromList pairs) Nil
|
||||
|
||||
assoc :: [MalVal] -> IOThrows MalVal
|
||||
assoc (MalHashMap hm _:kvs) = do
|
||||
pairs <- _pairup kvs
|
||||
return $ MalHashMap (Map.union (Map.fromList pairs) hm) Nil
|
||||
assoc _ = throwStr "invalid call to assoc"
|
||||
|
||||
dissoc :: [MalVal] -> IOThrows MalVal
|
||||
dissoc (MalHashMap hm _:ks) = do
|
||||
let remover = (\hm (MalString k) -> Map.delete k hm) in
|
||||
return $ MalHashMap (foldl remover hm ks) Nil
|
||||
let remover acc (MalString k) = return $ Map.delete k acc
|
||||
remover _ _ = throwStr "invalid dissoc"
|
||||
newMap <- foldlM remover hm ks
|
||||
return $ MalHashMap newMap Nil
|
||||
dissoc _ = throwStr "invalid call to dissoc"
|
||||
|
||||
get :: [MalVal] -> IOThrows MalVal
|
||||
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 [Nil, MalString _] = return Nil
|
||||
get _ = throwStr "invalid call to get"
|
||||
|
||||
contains_Q :: [MalVal] -> IOThrows MalVal
|
||||
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 [Nil, MalString _] = return MalFalse
|
||||
contains_Q _ = throwStr "invalid call to contains?"
|
||||
|
||||
keys :: [MalVal] -> IOThrows MalVal
|
||||
keys (MalHashMap hm _:[]) = do
|
||||
return $ MalList (map MalString (Map.keys hm)) Nil
|
||||
keys _ = throwStr "invalid call to keys"
|
||||
|
||||
vals :: [MalVal] -> IOThrows MalVal
|
||||
vals (MalHashMap hm _:[]) = do
|
||||
return $ MalList (Map.elems hm) Nil
|
||||
vals _ = throwStr "invalid call to vals"
|
||||
@ -141,18 +166,28 @@ vals _ = throwStr "invalid call to vals"
|
||||
|
||||
-- Sequence functions
|
||||
|
||||
_sequential_Q :: MalVal -> MalVal
|
||||
_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
|
||||
cons :: [MalVal] -> IOThrows MalVal
|
||||
cons [x, Nil ] = return (MalList [x] Nil)
|
||||
cons [x, MalList lst _] = return (MalList (x : lst) Nil)
|
||||
cons [x, MalVector lst _] = return (MalList (x : lst) Nil)
|
||||
cons _ = throwStr "invalid cons"
|
||||
|
||||
concat1 a (MalList lst _) = a ++ lst
|
||||
concat1 a (MalVector lst _) = a ++ lst
|
||||
do_concat args = return $ MalList (foldl concat1 [] args) Nil
|
||||
concat1 :: [MalVal] -> MalVal -> IOThrows [MalVal]
|
||||
concat1 a (MalList lst _) = return $ a ++ lst
|
||||
concat1 a (MalVector lst _) = return $ a ++ lst
|
||||
concat1 _ _ = throwStr "invalid concat"
|
||||
|
||||
do_concat :: [MalVal] -> IOThrows MalVal
|
||||
do_concat args = do
|
||||
xs <- foldlM concat1 [] args
|
||||
return $ MalList xs Nil
|
||||
|
||||
nth :: [MalVal] -> IOThrows MalVal
|
||||
nth ((MalList lst _):(MalNumber idx):[]) = do
|
||||
if idx < length lst then return $ lst !! idx
|
||||
else throwStr "nth: index out of range"
|
||||
@ -161,41 +196,53 @@ nth ((MalVector lst _):(MalNumber idx):[]) = do
|
||||
else throwStr "nth: index out of range"
|
||||
nth _ = throwStr "invalid call to nth"
|
||||
|
||||
first Nil = 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
|
||||
first :: [MalVal] -> IOThrows MalVal
|
||||
first [Nil ] = return Nil
|
||||
first [MalList [] _ ] = return Nil
|
||||
first [MalVector [] _ ] = return Nil
|
||||
first [MalList (x : _) _] = return x
|
||||
first [MalVector (x : _) _] = return x
|
||||
first _ = throwStr "invalid first"
|
||||
|
||||
rest Nil = MalList [] Nil
|
||||
rest (MalList lst _) = MalList (drop 1 lst) Nil
|
||||
rest (MalVector lst _) = MalList (drop 1 lst) Nil
|
||||
rest :: [MalVal] -> IOThrows MalVal
|
||||
rest [Nil ] = return $ MalList [] Nil
|
||||
rest [MalList (_ : xs) _] = return $ MalList xs Nil
|
||||
rest [MalVector (_ : xs) _] = return $ MalList xs Nil
|
||||
rest _ = throwStr "invalid rest"
|
||||
|
||||
empty_Q :: MalVal -> MalVal
|
||||
empty_Q Nil = MalTrue
|
||||
empty_Q (MalList [] _) = MalTrue
|
||||
empty_Q (MalVector [] _) = MalTrue
|
||||
empty_Q _ = MalFalse
|
||||
|
||||
count :: [MalVal] -> IOThrows MalVal
|
||||
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"
|
||||
|
||||
apply :: [MalVal] -> IOThrows MalVal
|
||||
apply args = do
|
||||
f <- _get_call args
|
||||
lst <- _to_list (last args)
|
||||
f $ (init (drop 1 args)) ++ lst
|
||||
|
||||
do_map :: [MalVal] -> IOThrows MalVal
|
||||
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
|
||||
|
||||
conj :: [MalVal] -> IOThrows MalVal
|
||||
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"
|
||||
|
||||
do_seq (l@(MalList [] _):[]) = return $ Nil
|
||||
do_seq (l@(MalList lst m):[]) = return $ l
|
||||
do_seq :: [MalVal] -> IOThrows MalVal
|
||||
do_seq [MalList [] _] = return Nil
|
||||
do_seq [l@(MalList _ _)] = return l
|
||||
do_seq (MalVector [] _:[]) = return $ Nil
|
||||
do_seq (MalVector lst _:[]) = return $ MalList lst Nil
|
||||
do_seq (MalString []:[]) = return $ Nil
|
||||
@ -205,15 +252,16 @@ do_seq _ = throwStr $ "seq: called on non-sequence"
|
||||
|
||||
-- Metadata functions
|
||||
|
||||
with_meta :: [MalVal] -> IOThrows MalVal
|
||||
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 [f@(MalFunc {}), m] = return $ f {meta=m}
|
||||
with_meta _ = throwStr $ "invalid with-meta call"
|
||||
|
||||
do_meta :: [MalVal] -> IOThrows MalVal
|
||||
do_meta ((MalList _ m):[]) = return m
|
||||
do_meta ((MalVector _ m):[]) = return m
|
||||
do_meta ((MalHashMap _ m):[]) = return m
|
||||
@ -224,28 +272,34 @@ do_meta _ = throwStr $ "invalid meta call"
|
||||
|
||||
-- Atom functions
|
||||
|
||||
atom :: [MalVal] -> IOThrows MalVal
|
||||
atom (val:[]) = do
|
||||
ref <- liftIO $ newIORef val
|
||||
return $ MalAtom ref Nil
|
||||
atom _ = throwStr "invalid atom call"
|
||||
|
||||
deref :: [MalVal] -> IOThrows MalVal
|
||||
deref (MalAtom ref _:[]) = do
|
||||
val <- liftIO $ readIORef ref
|
||||
return val
|
||||
deref _ = throwStr "invalid deref call"
|
||||
|
||||
reset_BANG :: [MalVal] -> IOThrows MalVal
|
||||
reset_BANG (MalAtom ref _:val:[]) = do
|
||||
liftIO $ writeIORef ref $ val
|
||||
return val
|
||||
reset_BANG _ = throwStr "invalid deref call"
|
||||
reset_BANG _ = throwStr "invalid reset!"
|
||||
|
||||
swap_BANG :: [MalVal] -> IOThrows MalVal
|
||||
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
|
||||
swap_BANG _ = throwStr "invalid swap!"
|
||||
|
||||
ns :: [(String, MalVal)]
|
||||
ns = [
|
||||
("=", _func equal_Q),
|
||||
("throw", _func throw),
|
||||
@ -266,7 +320,7 @@ ns = [
|
||||
("prn", _func prn),
|
||||
("println", _func println),
|
||||
("readline", _func do_readline),
|
||||
("read-string", _func (\[(MalString s)] -> read_str s)),
|
||||
("read-string", _func read_string),
|
||||
("slurp", _func slurp),
|
||||
|
||||
("<", _func $ cmp_op (<)),
|
||||
@ -293,11 +347,11 @@ ns = [
|
||||
("vals", _func $ vals),
|
||||
|
||||
("sequential?", _func $ run_1 _sequential_Q),
|
||||
("cons", _func $ run_2 $ cons),
|
||||
("cons", _func $ cons),
|
||||
("concat", _func $ do_concat),
|
||||
("nth", _func nth),
|
||||
("first", _func $ run_1 $ first),
|
||||
("rest", _func $ run_1 $ rest),
|
||||
("first", _func $ first),
|
||||
("rest", _func $ rest),
|
||||
("empty?", _func $ run_1 $ empty_Q),
|
||||
("count", _func $ count),
|
||||
("apply", _func $ apply),
|
||||
|
||||
@ -1,14 +1,13 @@
|
||||
module Env
|
||||
( Env, env_new, null_env, env_bind, env_find, env_get, env_set )
|
||||
( Env, env_new, env_bind, env_find, env_get, env_set )
|
||||
where
|
||||
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
||||
import Data.IORef (modifyIORef, newIORef, readIORef)
|
||||
import Control.Monad.Trans (liftIO)
|
||||
import Data.List (elemIndex)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Types
|
||||
import Printer
|
||||
|
||||
-- These Env types are defined in Types module to avoid dep cycle
|
||||
--data EnvData = EnvPair (Maybe Env, (Map.Map String MalVal))
|
||||
@ -17,49 +16,42 @@ import Printer
|
||||
env_new :: Maybe Env -> IO Env
|
||||
env_new outer = newIORef $ EnvPair (outer, (Map.fromList []))
|
||||
|
||||
null_env = env_new Nothing
|
||||
|
||||
env_bind :: Env -> [MalVal] -> [MalVal] -> IO Env
|
||||
env_bind :: Env -> [String] -> [MalVal] -> IO ()
|
||||
env_bind envRef binds exprs = do
|
||||
case (elemIndex (MalSymbol "&") binds) of
|
||||
case (elemIndex "&" binds) of
|
||||
Nothing -> do
|
||||
-- bind binds to exprs
|
||||
_ <- mapM (\(b,e) -> env_set envRef b e) $ zip binds exprs
|
||||
return envRef
|
||||
mapM_ (\(b,e) -> env_set envRef b e) $ zip binds exprs
|
||||
Just idx -> do
|
||||
-- Varargs binding
|
||||
_ <- mapM (\(b,e) -> env_set envRef b e) $
|
||||
zip (take idx binds) (take idx exprs)
|
||||
_ <- env_set envRef (binds !! (idx + 1))
|
||||
env_set envRef (binds !! (idx + 1))
|
||||
(MalList (drop idx exprs) Nil)
|
||||
return envRef
|
||||
|
||||
env_find :: Env -> MalVal -> IO (Maybe Env)
|
||||
env_find envRef sym@(MalSymbol key) = do
|
||||
env_find :: Env -> String -> IO (Maybe Env)
|
||||
env_find envRef key = do
|
||||
e <- readIORef envRef
|
||||
case e of
|
||||
EnvPair (o, m) -> case Map.lookup key m of
|
||||
Nothing -> case o of
|
||||
Nothing -> return Nothing
|
||||
Just o -> env_find o sym
|
||||
Just val -> return $ Just envRef
|
||||
Just outer -> env_find outer key
|
||||
Just _ -> return $ Just envRef
|
||||
|
||||
env_get :: Env -> MalVal -> IOThrows MalVal
|
||||
env_get envRef sym@(MalSymbol key) = do
|
||||
e1 <- liftIO $ env_find envRef sym
|
||||
env_get :: Env -> String -> IOThrows MalVal
|
||||
env_get envRef key = do
|
||||
e1 <- liftIO $ env_find envRef key
|
||||
case e1 of
|
||||
Nothing -> throwStr $ "'" ++ key ++ "' not found"
|
||||
Just eRef -> do
|
||||
e2 <- liftIO $ readIORef eRef
|
||||
case e2 of
|
||||
EnvPair (o,m) -> case Map.lookup key m of
|
||||
EnvPair (_, m) -> case Map.lookup key m of
|
||||
Nothing -> throwStr $ "env_get error"
|
||||
Just val -> return val
|
||||
|
||||
|
||||
env_set :: Env -> MalVal -> MalVal -> IO MalVal
|
||||
env_set envRef (MalSymbol key) val = do
|
||||
e <- readIORef envRef
|
||||
case e of
|
||||
EnvPair (o,m) -> writeIORef envRef $ EnvPair (o, (Map.insert key val m))
|
||||
return val
|
||||
env_set :: Env -> String -> MalVal -> IO ()
|
||||
env_set env key val = liftIO $ modifyIORef env f where
|
||||
f (EnvPair (o, m)) = EnvPair (o, Map.insert key val m)
|
||||
|
||||
@ -3,6 +3,7 @@ SRCS = step0_repl.hs step1_read_print.hs step2_eval.hs step3_env.hs \
|
||||
step8_macros.hs step9_try.hs stepA_mal.hs
|
||||
OTHER_SRCS = Readline.hs Types.hs Reader.hs Printer.hs Env.hs Core.hs
|
||||
BINS = $(SRCS:%.hs=%)
|
||||
ghc_flags = -Wall
|
||||
|
||||
#####################
|
||||
|
||||
@ -14,7 +15,7 @@ mal: $(word $(words $(BINS)),$(BINS))
|
||||
cp $< $@
|
||||
|
||||
$(BINS): %: %.hs $(OTHER_SRCS)
|
||||
ghc --make $< -o $@
|
||||
ghc ${ghc_flags} --make $< -o $@
|
||||
|
||||
clean:
|
||||
rm -f $(BINS) mal *.hi *.o
|
||||
|
||||
@ -14,13 +14,15 @@ import Types
|
||||
|
||||
|
||||
_pr_list :: Bool -> String -> [MalVal] -> String
|
||||
_pr_list pr sep [] = []
|
||||
_pr_list pr sep (x:[]) = (_pr_str pr x)
|
||||
_pr_list _ _ [] = []
|
||||
_pr_list pr _ [x] = _pr_str pr x
|
||||
_pr_list pr sep (x:xs) = (_pr_str pr x) ++ sep ++ (_pr_list pr sep xs)
|
||||
|
||||
_flatTuples :: [(String, MalVal)] -> [MalVal]
|
||||
_flatTuples ((a,b):xs) = MalString a : b : _flatTuples xs
|
||||
_flatTuples _ = []
|
||||
|
||||
unescape :: Char -> String
|
||||
unescape chr = case chr of
|
||||
'\n' -> "\\n"
|
||||
'\\' -> "\\\\"
|
||||
@ -40,8 +42,5 @@ _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
|
||||
|
||||
_pr_str _ (Func _ _) = "#<function>"
|
||||
_pr_str _ (MalFunc {f_ast=a, f_params=p}) = "(fn* " ++ show p ++ " " ++ _pr_str True a ++ ")"
|
||||
|
||||
@ -3,7 +3,7 @@ module Reader
|
||||
where
|
||||
|
||||
import Text.ParserCombinators.Parsec (
|
||||
Parser, parse, space, char, digit, letter, try,
|
||||
Parser, parse, char, digit, letter, try,
|
||||
(<|>), oneOf, noneOf, many, many1, skipMany, skipMany1, sepEndBy)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
@ -14,7 +14,7 @@ spaces = skipMany1 (oneOf ", \n")
|
||||
|
||||
comment :: Parser ()
|
||||
comment = do
|
||||
char ';'
|
||||
_ <- char ';'
|
||||
skipMany (noneOf "\r\n")
|
||||
|
||||
ignored :: Parser ()
|
||||
@ -25,7 +25,7 @@ symbol = oneOf "!#$%&|*+-/:<=>?@^_~"
|
||||
|
||||
escaped :: Parser Char
|
||||
escaped = do
|
||||
char '\\'
|
||||
_ <- char '\\'
|
||||
x <- oneOf "\\\"n"
|
||||
case x of
|
||||
'n' -> return '\n'
|
||||
@ -44,9 +44,9 @@ read_negative_number = do
|
||||
|
||||
read_string :: Parser MalVal
|
||||
read_string = do
|
||||
char '"'
|
||||
_ <- char '"'
|
||||
x <- many (escaped <|> noneOf "\\\"")
|
||||
char '"'
|
||||
_ <- char '"'
|
||||
return $ MalString x
|
||||
|
||||
read_symbol :: Parser MalVal
|
||||
@ -62,7 +62,7 @@ read_symbol = do
|
||||
|
||||
read_keyword :: Parser MalVal
|
||||
read_keyword = do
|
||||
char ':'
|
||||
_ <- char ':'
|
||||
x <- many (letter <|> digit <|> symbol)
|
||||
return $ MalString $ "\x029e" ++ x
|
||||
|
||||
@ -75,68 +75,69 @@ read_atom = read_number
|
||||
|
||||
read_list :: Parser MalVal
|
||||
read_list = do
|
||||
char '('
|
||||
_ <- char '('
|
||||
ignored
|
||||
x <- sepEndBy read_form ignored
|
||||
char ')'
|
||||
_ <- char ')'
|
||||
return $ MalList x Nil
|
||||
|
||||
read_vector :: Parser MalVal
|
||||
read_vector = do
|
||||
char '['
|
||||
_ <- char '['
|
||||
ignored
|
||||
x <- sepEndBy read_form ignored
|
||||
char ']'
|
||||
_ <- char ']'
|
||||
return $ MalVector x Nil
|
||||
|
||||
-- TODO: propagate error properly
|
||||
_pairs [x] = error "Odd number of elements to _pairs"
|
||||
_pairs :: [MalVal] -> [(String, MalVal)]
|
||||
_pairs [] = []
|
||||
_pairs (MalString x:y:xs) = (x,y):_pairs xs
|
||||
_pairs _ = error "Invalid {..} hash map definition"
|
||||
|
||||
read_hash_map :: Parser MalVal
|
||||
read_hash_map = do
|
||||
char '{'
|
||||
_ <- char '{'
|
||||
ignored
|
||||
x <- sepEndBy read_form ignored
|
||||
char '}'
|
||||
_ <- char '}'
|
||||
return $ MalHashMap (Map.fromList $ _pairs x) Nil
|
||||
|
||||
-- reader macros
|
||||
read_quote :: Parser MalVal
|
||||
read_quote = do
|
||||
char '\''
|
||||
_ <- char '\''
|
||||
x <- read_form
|
||||
return $ MalList [MalSymbol "quote", x] Nil
|
||||
|
||||
read_quasiquote :: Parser MalVal
|
||||
read_quasiquote = do
|
||||
char '`'
|
||||
_ <- char '`'
|
||||
x <- read_form
|
||||
return $ MalList [MalSymbol "quasiquote", x] Nil
|
||||
|
||||
read_splice_unquote :: Parser MalVal
|
||||
read_splice_unquote = do
|
||||
char '~'
|
||||
char '@'
|
||||
_ <- char '~'
|
||||
_ <- char '@'
|
||||
x <- read_form
|
||||
return $ MalList [MalSymbol "splice-unquote", x] Nil
|
||||
|
||||
read_unquote :: Parser MalVal
|
||||
read_unquote = do
|
||||
char '~'
|
||||
_ <- char '~'
|
||||
x <- read_form
|
||||
return $ MalList [MalSymbol "unquote", x] Nil
|
||||
|
||||
read_deref :: Parser MalVal
|
||||
read_deref = do
|
||||
char '@'
|
||||
_ <- char '@'
|
||||
x <- read_form
|
||||
return $ MalList [MalSymbol "deref", x] Nil
|
||||
|
||||
read_with_meta :: Parser MalVal
|
||||
read_with_meta = do
|
||||
char '^'
|
||||
_ <- char '^'
|
||||
m <- read_form
|
||||
x <- read_form
|
||||
return $ MalList [MalSymbol "with-meta", x, m] Nil
|
||||
|
||||
@ -11,28 +11,30 @@ import qualified System.Console.Readline as RL
|
||||
import Control.Monad (when)
|
||||
import System.Directory (getHomeDirectory, doesFileExist)
|
||||
|
||||
import System.IO (hGetLine, hFlush, hIsEOF, stdin, stdout)
|
||||
import System.IO.Error (tryIOError)
|
||||
|
||||
history_file :: IO String
|
||||
history_file = do
|
||||
home <- getHomeDirectory
|
||||
return $ home ++ "/.mal-history"
|
||||
|
||||
load_history :: IO ()
|
||||
load_history = do
|
||||
hfile <- history_file
|
||||
fileExists <- doesFileExist hfile
|
||||
when fileExists $ do
|
||||
content <- readFile hfile
|
||||
mapM RL.addHistory (lines content)
|
||||
mapM_ RL.addHistory (lines content)
|
||||
return ()
|
||||
return ()
|
||||
|
||||
readline :: String -> IO (Maybe String)
|
||||
readline prompt = do
|
||||
hfile <- history_file
|
||||
maybeLine <- RL.readline prompt
|
||||
case maybeLine of
|
||||
case maybeLine of
|
||||
Just line -> do
|
||||
RL.addHistory line
|
||||
res <- tryIOError (appendFile hfile (line ++ "\n"))
|
||||
_ <- tryIOError (appendFile hfile (line ++ "\n"))
|
||||
return maybeLine
|
||||
_ -> return maybeLine
|
||||
|
||||
@ -1,14 +1,13 @@
|
||||
module Types
|
||||
(MalVal (..), MalError (..), IOThrows (..), Fn (..), EnvData (..), Env,
|
||||
(MalVal (..), MalError (..), IOThrows, Fn (..), EnvData (..), Env,
|
||||
throwStr, throwMalVal, _get_call, _to_list,
|
||||
_func, _malfunc, _fn_Q, _macro_Q,
|
||||
_func, _fn_Q, _macro_Q,
|
||||
_nil_Q, _true_Q, _false_Q, _string_Q, _symbol_Q, _keyword_Q, _number_Q,
|
||||
_list_Q, _vector_Q, _hash_map_Q, _atom_Q)
|
||||
where
|
||||
|
||||
import Data.IORef (IORef)
|
||||
import qualified Data.Map as Map
|
||||
import Control.Exception as CE
|
||||
import Control.Monad.Except
|
||||
|
||||
|
||||
@ -26,12 +25,12 @@ data MalVal = Nil
|
||||
| MalAtom (IORef MalVal) MalVal
|
||||
| Func Fn MalVal
|
||||
| MalFunc {fn :: Fn,
|
||||
ast :: MalVal,
|
||||
env :: Env,
|
||||
params :: MalVal,
|
||||
f_ast :: MalVal,
|
||||
f_params :: [String],
|
||||
macro :: Bool,
|
||||
meta :: MalVal}
|
||||
|
||||
_equal_Q :: MalVal -> MalVal -> Bool
|
||||
_equal_Q Nil Nil = True
|
||||
_equal_Q MalFalse MalFalse = True
|
||||
_equal_Q MalTrue MalTrue = True
|
||||
@ -73,10 +72,12 @@ type Env = IORef EnvData
|
||||
|
||||
-- General functions --
|
||||
|
||||
_get_call :: [MalVal] -> IOThrows ([MalVal] -> IOThrows MalVal)
|
||||
_get_call ((Func (Fn f) _) : _) = return f
|
||||
_get_call (MalFunc {fn=(Fn f)} : _) = return f
|
||||
_get_call _ = throwStr "_get_call first parameter is not a function "
|
||||
|
||||
_to_list :: MalVal -> IOThrows [MalVal]
|
||||
_to_list (MalList lst _) = return lst
|
||||
_to_list (MalVector lst _) = return lst
|
||||
_to_list _ = throwStr "_to_list expected a MalList or MalVector"
|
||||
@ -88,63 +89,69 @@ _to_list _ = throwStr "_to_list expected a MalList or MalVector"
|
||||
|
||||
-- Functions
|
||||
|
||||
_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, meta=Nil}
|
||||
_malfunc_meta ast env params fn meta = MalFunc {fn=(Fn fn), ast=ast,
|
||||
env=env, params=params,
|
||||
macro=False, meta=meta}
|
||||
_func :: ([MalVal] -> IOThrows MalVal) -> MalVal
|
||||
_func f = Func (Fn f) Nil
|
||||
|
||||
_fn_Q :: MalVal -> MalVal
|
||||
_fn_Q (MalFunc {macro=False}) = MalTrue
|
||||
_fn_Q (Func _ _) = MalTrue
|
||||
_fn_Q _ = MalFalse
|
||||
|
||||
_macro_Q :: MalVal -> MalVal
|
||||
_macro_Q (MalFunc {macro=True}) = MalTrue
|
||||
_macro_Q _ = MalFalse
|
||||
|
||||
|
||||
-- Scalars
|
||||
_nil_Q :: MalVal -> MalVal
|
||||
_nil_Q Nil = MalTrue
|
||||
_nil_Q _ = MalFalse
|
||||
|
||||
_true_Q :: MalVal -> MalVal
|
||||
_true_Q MalTrue = MalTrue
|
||||
_true_Q _ = MalFalse
|
||||
|
||||
_false_Q :: MalVal -> MalVal
|
||||
_false_Q MalFalse = MalTrue
|
||||
_false_Q _ = MalFalse
|
||||
|
||||
_symbol_Q :: MalVal -> MalVal
|
||||
_symbol_Q (MalSymbol _) = MalTrue
|
||||
_symbol_Q _ = MalFalse
|
||||
|
||||
_string_Q :: MalVal -> MalVal
|
||||
_string_Q (MalString ('\x029e':_)) = MalFalse
|
||||
_string_Q (MalString _) = MalTrue
|
||||
_string_Q _ = MalFalse
|
||||
|
||||
_keyword_Q :: MalVal -> MalVal
|
||||
_keyword_Q (MalString ('\x029e':_)) = MalTrue
|
||||
_keyword_Q _ = MalFalse
|
||||
|
||||
_number_Q :: MalVal -> MalVal
|
||||
_number_Q (MalNumber _) = MalTrue
|
||||
_number_Q _ = MalFalse
|
||||
|
||||
-- Lists
|
||||
|
||||
_list_Q :: MalVal -> MalVal
|
||||
_list_Q (MalList _ _) = MalTrue
|
||||
_list_Q _ = MalFalse
|
||||
|
||||
-- Vectors
|
||||
|
||||
_vector_Q :: MalVal -> MalVal
|
||||
_vector_Q (MalVector _ _) = MalTrue
|
||||
_vector_Q _ = MalFalse
|
||||
|
||||
-- Hash Maps
|
||||
|
||||
_hash_map_Q :: MalVal -> MalVal
|
||||
_hash_map_Q (MalHashMap _ _) = MalTrue
|
||||
_hash_map_Q _ = MalFalse
|
||||
|
||||
-- Atoms
|
||||
|
||||
_atom_Q :: MalVal -> MalVal
|
||||
_atom_Q (MalAtom _ _) = MalTrue
|
||||
_atom_Q _ = MalFalse
|
||||
|
||||
@ -3,7 +3,6 @@ import System.Environment (getArgs)
|
||||
import Control.Monad (mapM)
|
||||
import Control.Monad.Except (runExceptT)
|
||||
import Control.Monad.Trans (liftIO)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Traversable as DT
|
||||
|
||||
import Readline (readline, load_history)
|
||||
@ -39,9 +38,9 @@ quasiquote ast =
|
||||
_ -> MalList [(MalSymbol "quote"), ast] Nil
|
||||
|
||||
is_macro_call :: MalVal -> Env -> IOThrows Bool
|
||||
is_macro_call (MalList (a0@(MalSymbol _) : rest) _) env = do
|
||||
e <- liftIO $ env_find env a0
|
||||
case e of
|
||||
is_macro_call (MalList ((MalSymbol a0) : _) _) env = do
|
||||
maybeE <- liftIO $ env_find env a0
|
||||
case maybeE of
|
||||
Just e -> do
|
||||
f <- env_get e a0
|
||||
case f of
|
||||
@ -51,7 +50,7 @@ is_macro_call (MalList (a0@(MalSymbol _) : rest) _) env = do
|
||||
is_macro_call _ _ = return False
|
||||
|
||||
macroexpand :: MalVal -> Env -> IOThrows MalVal
|
||||
macroexpand ast@(MalList (a0 : args) _) env = do
|
||||
macroexpand ast@(MalList (MalSymbol a0 : args) _) env = do
|
||||
mc <- is_macro_call ast env
|
||||
if mc then do
|
||||
mac <- env_get env a0
|
||||
@ -66,71 +65,76 @@ macroexpand ast@(MalList (a0 : args) _) env = do
|
||||
macroexpand ast _ = return ast
|
||||
|
||||
eval_ast :: MalVal -> Env -> IOThrows MalVal
|
||||
eval_ast sym@(MalSymbol _) env = env_get env sym
|
||||
eval_ast ast@(MalList lst m) env = do
|
||||
eval_ast (MalSymbol s) env = env_get env s
|
||||
eval_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
|
||||
eval_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
|
||||
eval_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
|
||||
eval_ast ast _ = return ast
|
||||
|
||||
let_bind :: Env -> [MalVal] -> IOThrows Env
|
||||
let_bind env [] = return env
|
||||
let_bind env (b:e:xs) = do
|
||||
let_bind :: Env -> [MalVal] -> IOThrows ()
|
||||
let_bind _ [] = return ()
|
||||
let_bind env (MalSymbol b : e : xs) = do
|
||||
evaled <- eval e env
|
||||
x <- liftIO $ env_set env b evaled
|
||||
liftIO $ env_set env b evaled
|
||||
let_bind env xs
|
||||
let_bind _ _ = throwStr "invalid let*"
|
||||
|
||||
unwrapSymbol :: MalVal -> IOThrows String
|
||||
unwrapSymbol (MalSymbol s) = return s
|
||||
unwrapSymbol _ = throwStr "fn* expects a sequence of symbols"
|
||||
|
||||
apply_ast :: MalVal -> Env -> IOThrows MalVal
|
||||
apply_ast ast@(MalList [] _) env = do
|
||||
apply_ast ast@(MalList [] _) _ = do
|
||||
return ast
|
||||
apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do
|
||||
apply_ast (MalList (MalSymbol "def!" : args) _) env = do
|
||||
case args of
|
||||
(a1@(MalSymbol _): a2 : []) -> do
|
||||
[MalSymbol a1, a2] -> do
|
||||
evaled <- eval a2 env
|
||||
liftIO $ env_set env a1 evaled
|
||||
return evaled
|
||||
_ -> throwStr "invalid def!"
|
||||
apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do
|
||||
apply_ast (MalList (MalSymbol "let*" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : []) -> do
|
||||
params <- (_to_list a1)
|
||||
params <- _to_list a1
|
||||
let_env <- liftIO $ env_new $ Just env
|
||||
let_bind let_env params
|
||||
eval a2 let_env
|
||||
_ -> throwStr "invalid let*"
|
||||
apply_ast ast@(MalList (MalSymbol "quote" : args) _) env = do
|
||||
apply_ast (MalList (MalSymbol "quote" : args) _) _ = do
|
||||
case args of
|
||||
a1 : [] -> return a1
|
||||
_ -> throwStr "invalid quote"
|
||||
apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do
|
||||
apply_ast (MalList (MalSymbol "quasiquote" : args) _) env = do
|
||||
case args of
|
||||
a1 : [] -> eval (quasiquote a1) env
|
||||
_ -> throwStr "invalid quasiquote"
|
||||
|
||||
apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = do
|
||||
apply_ast (MalList (MalSymbol "defmacro!" : args) _) env =
|
||||
case args of
|
||||
(a1 : a2 : []) -> do
|
||||
(MalSymbol 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
|
||||
liftIO $ env_set env a1 new_func
|
||||
MalFunc {} -> do
|
||||
let new_func = func {macro=True, meta=Nil}
|
||||
liftIO $ env_set env a1 new_func
|
||||
return new_func
|
||||
_ -> throwStr "defmacro! on non-function"
|
||||
_ -> throwStr "invalid defmacro!"
|
||||
apply_ast ast@(MalList (MalSymbol "macroexpand" : args) _) env = do
|
||||
apply_ast (MalList (MalSymbol "macroexpand" : args) _) env = do
|
||||
case args of
|
||||
(a1 : []) -> macroexpand a1 env
|
||||
_ -> throwStr "invalid macroexpand"
|
||||
apply_ast ast@(MalList (MalSymbol "try*" : args) _) env = do
|
||||
apply_ast (MalList (MalSymbol "try*" : args) _) env = do
|
||||
case args of
|
||||
(a1 : []) -> eval a1 env
|
||||
(a1 : (MalList ((MalSymbol "catch*") : a21 : a22 : []) _) : []) -> do
|
||||
[a1, MalList [MalSymbol "catch*", MalSymbol a21, a22] _] -> do
|
||||
res <- liftIO $ runExceptT $ eval a1 env
|
||||
case res of
|
||||
Right val -> return val
|
||||
@ -142,15 +146,16 @@ apply_ast ast@(MalList (MalSymbol "try*" : args) _) env = do
|
||||
liftIO $ env_set try_env a21 exc
|
||||
eval a22 try_env
|
||||
_ -> throwStr "invalid try*"
|
||||
apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
|
||||
apply_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
|
||||
_ -> throwStr "invalid do"
|
||||
|
||||
apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
|
||||
apply_ast (MalList (MalSymbol "if" : args) _) env = do
|
||||
case args of
|
||||
(a1 : a2 : a3 : []) -> do
|
||||
cond <- eval a1 env
|
||||
@ -163,15 +168,16 @@ apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
|
||||
then return Nil
|
||||
else eval a2 env
|
||||
_ -> throwStr "invalid if"
|
||||
apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do
|
||||
apply_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 <- liftIO $ env_new $ Just env
|
||||
fn_env2 <- liftIO $ env_bind fn_env1 params args
|
||||
eval a2 fn_env2))
|
||||
symbols <- mapM unwrapSymbol params
|
||||
let f xs = do
|
||||
fn_env <- liftIO $ env_new $ Just env
|
||||
liftIO $ env_bind fn_env symbols xs
|
||||
eval a2 fn_env
|
||||
return $ MalFunc {f_ast=a2, f_params=symbols, meta=Nil, macro=False, fn=Fn f}
|
||||
_ -> throwStr "invalid fn*"
|
||||
apply_ast ast@(MalList _ _) env = do
|
||||
mc <- is_macro_call ast env
|
||||
@ -185,15 +191,13 @@ apply_ast ast@(MalList _ _) env = do
|
||||
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 <- liftIO $ env_new $ Just fn_env
|
||||
fn_env2 <- liftIO $ env_bind fn_env1 params rest
|
||||
eval ast fn_env2
|
||||
el ->
|
||||
throwStr $ "invalid apply: " ++ (show el)
|
||||
(MalList (MalFunc {fn=Fn f} : rest) _) ->
|
||||
f rest
|
||||
_ ->
|
||||
throwStr $ "invalid apply: " ++ Printer._pr_str True el
|
||||
_ -> return ast
|
||||
apply_ast _ _ = throwStr "internal error in apply_ast"
|
||||
|
||||
|
||||
eval :: MalVal -> Env -> IOThrows MalVal
|
||||
eval ast env = do
|
||||
@ -204,15 +208,15 @@ eval ast env = do
|
||||
|
||||
-- print
|
||||
mal_print :: MalVal -> String
|
||||
mal_print exp = show exp
|
||||
mal_print = Printer._pr_str True
|
||||
|
||||
-- repl
|
||||
|
||||
rep :: Env -> String -> IOThrows String
|
||||
rep env line = do
|
||||
ast <- mal_read line
|
||||
exp <- eval ast env
|
||||
return $ mal_print exp
|
||||
e <- eval ast env
|
||||
return $ mal_print e
|
||||
|
||||
repl_loop :: Env -> IO ()
|
||||
repl_loop env = do
|
||||
@ -223,13 +227,18 @@ repl_loop env = do
|
||||
Just str -> do
|
||||
res <- runExceptT $ rep env str
|
||||
out <- case res of
|
||||
Left (StringError str) -> return $ "Error: " ++ str
|
||||
Left (MalValError mv) -> return $ "Error: " ++ (show mv)
|
||||
Left (StringError s) -> return $ "Error: " ++ s
|
||||
Left (MalValError mv) -> return $ "Error: " ++ _pr_str True mv
|
||||
Right val -> return val
|
||||
putStrLn out
|
||||
hFlush stdout
|
||||
repl_loop env
|
||||
|
||||
evalBuiltIn :: Env -> [MalVal] -> IOThrows MalVal
|
||||
evalBuiltIn repl_env [ast] = eval ast repl_env
|
||||
evalBuiltIn _ _ = throwStr "invalid eval"
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
load_history
|
||||
@ -237,23 +246,23 @@ main = do
|
||||
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)
|
||||
mapM_ (uncurry $ env_set repl_env) Core.ns
|
||||
env_set repl_env "eval" (_func (evalBuiltIn repl_env))
|
||||
env_set repl_env "*ARGV*" (MalList [] Nil)
|
||||
|
||||
-- core.mal: defined using the language itself
|
||||
runExceptT $ rep repl_env "(def! *host-language* \"haskell\")"
|
||||
runExceptT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
|
||||
runExceptT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
|
||||
runExceptT $ 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)))))))"
|
||||
runExceptT $ rep repl_env "(def! inc (fn* [x] (+ x 1)))"
|
||||
runExceptT $ rep repl_env "(def! gensym (let* [counter (atom 0)] (fn* [] (symbol (str \"G__\" (swap! counter inc))))))"
|
||||
runExceptT $ rep repl_env "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))"
|
||||
_ <- runExceptT $ rep repl_env "(def! *host-language* \"haskell\")"
|
||||
_ <- runExceptT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
|
||||
_ <- runExceptT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
|
||||
_ <- runExceptT $ 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)))))))"
|
||||
_ <- runExceptT $ rep repl_env "(def! inc (fn* [x] (+ x 1)))"
|
||||
_ <- runExceptT $ rep repl_env "(def! gensym (let* [counter (atom 0)] (fn* [] (symbol (str \"G__\" (swap! counter inc))))))"
|
||||
_ <- runExceptT $ rep repl_env "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))"
|
||||
|
||||
if length args > 0 then do
|
||||
env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)) Nil)
|
||||
runExceptT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
|
||||
env_set repl_env "*ARGV*" (MalList (map MalString (drop 1 args)) Nil)
|
||||
_ <- runExceptT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
|
||||
return ()
|
||||
else do
|
||||
runExceptT $ rep repl_env "(println (str \"Mal [\" *host-language* \"]\"))"
|
||||
_ <- runExceptT $ rep repl_env "(println (str \"Mal [\" *host-language* \"]\"))"
|
||||
repl_loop repl_env
|
||||
|
||||
Loading…
Reference in New Issue
Block a user