-import Control.Monad (when, mapM)
-import Control.Monad.Error (throwError)
+import System.IO (hFlush, stdout)
+import Control.Monad (mapM)
+import Control.Monad.Error (runErrorT)
+import Control.Monad.Trans (liftIO)
import qualified Data.Map as Map
import qualified Data.Traversable as DT
import Core as Core
-- read
-mal_read :: String -> IO MalVal
+mal_read :: String -> IOThrows MalVal
mal_read str = read_str str
-- eval
-eval_ast :: MalVal -> Env -> IO MalVal
+eval_ast :: MalVal -> Env -> IOThrows 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 $ MalHashMap new_hm m
eval_ast ast env = return ast
-let_bind :: Env -> [MalVal] -> IO Env
+let_bind :: Env -> [MalVal] -> IOThrows Env
let_bind env [] = return env
let_bind env (b:e:xs) = do
evaled <- eval e env
- x <- env_set env b evaled
+ x <- liftIO $ env_set env b evaled
let_bind env xs
-apply_ast :: MalVal -> Env -> IO MalVal
+apply_ast :: MalVal -> Env -> IOThrows 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!"
+ liftIO $ env_set env a1 evaled
+ _ -> throwStr "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_env <- liftIO $ env_new $ Just env
let_bind let_env params
eval a2 let_env
- _ -> error $ "invalid let*"
+ _ -> throwStr "invalid let*"
apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
case args of
([]) -> return Nil
if cond == MalFalse || cond == Nil
then return Nil
else eval a2 env
- _ -> error $ "invalid if"
+ _ -> throwStr "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)
+ fn_env1 <- liftIO $ env_new $ Just env
+ fn_env2 <- liftIO $ env_bind fn_env1 params args
eval a2 fn_env2))
- _ -> error $ "invalid fn*"
+ _ -> throwStr "invalid fn*"
apply_ast ast@(MalList _ _) env = 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)
+ fn_env1 <- liftIO $ env_new $ Just fn_env
+ fn_env2 <- liftIO $ env_bind fn_env1 params rest
eval ast fn_env2
el ->
- error $ "invalid apply: " ++ (show el)
+ throwStr $ "invalid apply: " ++ (show el)
-eval :: MalVal -> Env -> IO MalVal
+eval :: MalVal -> Env -> IOThrows MalVal
eval ast env = do
case ast of
(MalList _ _) -> apply_ast ast env
-- repl
-rep :: Env -> String -> IO String
+rep :: Env -> String -> IOThrows String
rep env line = do
ast <- mal_read line
exp <- eval ast env
Nothing -> return ()
Just "" -> repl_loop env
Just str -> do
- out <- catchAny (rep env str) $ \e -> do
- return $ "Error: " ++ (show e)
+ res <- runErrorT $ rep env str
+ out <- case res of
+ Left (StringError str) -> return $ "Error: " ++ str
+ Left (MalValError mv) -> return $ "Error: " ++ (show mv)
+ Right val -> return val
putStrLn out
+ hFlush stdout
repl_loop env
main = do
(mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns)
-- core.mal: defined using the language itself
- rep repl_env "(def! not (fn* (a) (if a false true)))"
+ runErrorT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
repl_loop repl_env