aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--README.md4
-rw-r--r--haskell/Core.hs104
-rw-r--r--haskell/Env.hs17
-rw-r--r--haskell/Reader.hs4
-rw-r--r--haskell/Readline.hs2
-rw-r--r--haskell/Types.hs32
-rw-r--r--haskell/step0_repl.hs2
-rw-r--r--haskell/step1_read_print.hs16
-rw-r--r--haskell/step2_eval.hs35
-rw-r--r--haskell/step3_env.hs46
-rw-r--r--haskell/step4_if_fn_do.hs48
-rw-r--r--haskell/step5_tco.hs52
-rw-r--r--haskell/step6_file.hs56
-rw-r--r--haskell/step7_quote.hs60
-rw-r--r--haskell/step8_macros.hs79
-rw-r--r--haskell/step9_try.hs94
-rw-r--r--haskell/stepA_interop.hs98
17 files changed, 425 insertions, 324 deletions
diff --git a/README.md b/README.md
index 2d18e92..1a6f7af 100644
--- a/README.md
+++ b/README.md
@@ -113,7 +113,9 @@ make
### Haskell
Install the Haskell compiler (ghc/ghci), the Haskell platform and
-either the editline package (BSD) or the readline package (GPL).
+either the editline package (BSD) or the readline package (GPL). On
+Ubuntu these packages are: ghc, haskell-platform,
+libghc-readline-dev/libghc-editline-dev
```
cd haskell
diff --git a/haskell/Core.hs b/haskell/Core.hs
index 4bb5517..d1034c1 100644
--- a/haskell/Core.hs
+++ b/haskell/Core.hs
@@ -2,7 +2,9 @@ module Core
( ns )
where
+import System.IO (hFlush, stdout)
import Control.Exception (catch)
+import Control.Monad.Trans (liftIO)
import qualified Data.Map as Map
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
@@ -15,23 +17,28 @@ import Printer (_pr_str, _pr_list)
-- General functions
equal_Q [a, b] = return $ if a == b then MalTrue else MalFalse
-equal_Q _ = error $ "illegal arguments to ="
+equal_Q _ = throwStr "illegal arguments to ="
-run_1 :: (MalVal -> MalVal) -> [MalVal] -> IO MalVal
+run_1 :: (MalVal -> MalVal) -> [MalVal] -> IOThrows MalVal
run_1 f (x:[]) = return $ f x
-run_1 _ _ = error $ "function takes a single argument"
+run_1 _ _ = throwStr "function takes a single argument"
-run_2 :: (MalVal -> MalVal -> MalVal) -> [MalVal] -> IO MalVal
+run_2 :: (MalVal -> MalVal -> MalVal) -> [MalVal] -> IOThrows MalVal
run_2 f (x:y:[]) = return $ f x y
-run_2 _ _ = error $ "function takes a two arguments"
+run_2 _ _ = throwStr "function takes a two arguments"
+
+-- Error/Exception functions
+
+throw (mv:[]) = throwMalVal mv
+throw _ = throwStr "illegal arguments to throw"
-- Scalar functions
-symbol (MalString str) = MalSymbol str
-symbol _ = error $ "symbol called with non-string"
+symbol (MalString str:[]) = return $ MalSymbol str
+symbol _ = throwStr "symbol called with non-string"
-keyword (MalString str) = MalString $ "\x029e" ++ str
-keyword _ = error $ "keyword called with non-string"
+keyword (MalString str:[]) = return $ MalString $ "\x029e" ++ str
+keyword _ = throwStr "keyword called with non-string"
-- String functions
@@ -43,37 +50,39 @@ str args = do
return $ MalString $ _pr_list False "" args
prn args = do
- putStrLn $ _pr_list True " " args
+ liftIO $ putStrLn $ _pr_list True " " args
+ liftIO $ hFlush stdout
return Nil
println args = do
- putStrLn $ _pr_list False " " args
+ liftIO $ putStrLn $ _pr_list False " " args
+ liftIO $ hFlush stdout
return Nil
slurp ([MalString path]) = do
- str <- readFile path
+ str <- liftIO $ readFile path
return $ MalString str
-slurp _ = error $ "invalid arguments to slurp"
+slurp _ = throwStr "invalid arguments to slurp"
do_readline ([MalString prompt]) = do
- str <- readline prompt
+ str <- liftIO $ readline prompt
case str of
- Nothing -> error "readline failed"
+ Nothing -> throwStr "readline failed"
Just str -> return $ MalString str
-do_readline _ = error $ "invalid arguments to readline"
+do_readline _ = throwStr "invalid arguments to readline"
-- Numeric functions
num_op op [MalNumber a, MalNumber b] = do
return $ MalNumber $ op a b
-num_op _ _ = error $ "illegal arguments to number operation"
+num_op _ _ = throwStr "illegal arguments to number operation"
cmp_op op [MalNumber a, MalNumber b] = do
return $ if op a b then MalTrue else MalFalse
-cmp_op _ _ = error $ "illegal arguments to comparison operation"
+cmp_op _ _ = throwStr "illegal arguments to comparison operation"
time_ms _ = do
- t <- getPOSIXTime
+ t <- liftIO $ getPOSIXTime
return $ MalNumber $ round (t * 1000)
@@ -87,7 +96,7 @@ vector args = return $ MalVector args Nil
-- Hash Map functions
-_pairup [x] = error "Odd number of elements to _pairup"
+_pairup [x] = throwStr "Odd number of elements to _pairup"
_pairup [] = return []
_pairup (MalString x:y:xs) = do
rest <- _pairup xs
@@ -100,33 +109,33 @@ hash_map args = do
assoc (MalHashMap hm _:kvs) = do
pairs <- _pairup kvs
return $ MalHashMap (Map.union (Map.fromList pairs) hm) Nil
-assoc _ = error $ "invalid call to assoc"
+assoc _ = throwStr "invalid call to assoc"
dissoc (MalHashMap hm _:ks) = do
let remover = (\hm (MalString k) -> Map.delete k hm) in
return $ MalHashMap (foldl remover hm ks) Nil
-dissoc _ = error $ "invalid call to dissoc"
+dissoc _ = throwStr "invalid call to dissoc"
get (MalHashMap hm _:MalString k:[]) = do
case Map.lookup k hm of
Just mv -> return mv
Nothing -> return Nil
get (Nil:MalString k:[]) = return Nil
-get _ = error $ "invalid call to get"
+get _ = throwStr "invalid call to get"
contains_Q (MalHashMap hm _:MalString k:[]) = do
if Map.member k hm then return MalTrue
else return MalFalse
contains_Q (Nil:MalString k:[]) = return MalFalse
-contains_Q _ = error $ "invalid call to contains?"
+contains_Q _ = throwStr "invalid call to contains?"
keys (MalHashMap hm _:[]) = do
return $ MalList (map MalString (Map.keys hm)) Nil
-keys _ = error $ "invalid call to keys"
+keys _ = throwStr "invalid call to keys"
vals (MalHashMap hm _:[]) = do
return $ MalList (Map.elems hm) Nil
-vals _ = error $ "invalid call to vals"
+vals _ = throwStr "invalid call to vals"
-- Sequence functions
@@ -145,11 +154,11 @@ do_concat args = return $ MalList (foldl concat1 [] args) Nil
nth ((MalList lst _):(MalNumber idx):[]) = do
if idx < length lst then return $ lst !! idx
- else error "nth: index out of range"
+ else throwStr "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"
+ else throwStr "nth: index out of range"
+nth _ = throwStr "invalid call to nth"
first (MalList lst _) = if length lst > 0 then lst !! 0 else Nil
first (MalVector lst _) = if length lst > 0 then lst !! 0 else Nil
@@ -162,14 +171,14 @@ 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"
+count (Nil:[]) = return $ MalNumber 0
+count (MalList lst _:[]) = return $ MalNumber $ length lst
+count (MalVector lst _:[]) = return $ MalNumber $ length lst
+count _ = throwStr $ "non-sequence passed to count"
conj ((MalList lst _):args) = return $ MalList ((reverse args) ++ lst) Nil
conj ((MalVector lst _):args) = return $ MalVector (lst ++ args) Nil
-conj _ = error $ "illegal arguments to conj"
+conj _ = throwStr $ "illegal arguments to conj"
apply args = do
f <- _get_call args
@@ -191,7 +200,7 @@ 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"
+with_meta _ = throwStr $ "invalid with-meta call"
do_meta ((MalList _ m):[]) = return m
do_meta ((MalVector _ m):[]) = return m
@@ -199,40 +208,41 @@ 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"
+do_meta _ = throwStr $ "invalid meta call"
-- Atom functions
atom (val:[]) = do
- ref <- newIORef val
+ ref <- liftIO $ newIORef val
return $ MalAtom ref Nil
-atom _ = error "invalid atom call"
+atom _ = throwStr "invalid atom call"
deref (MalAtom ref _:[]) = do
- val <- readIORef ref
+ val <- liftIO $ readIORef ref
return val
-deref _ = error "invalid deref call"
+deref _ = throwStr "invalid deref call"
reset_BANG (MalAtom ref _:val:[]) = do
- _ <- writeIORef ref $ val
+ liftIO $ writeIORef ref $ val
return val
-reset_BANG _ = error "invalid deref call"
+reset_BANG _ = throwStr "invalid deref call"
swap_BANG (MalAtom ref _:args) = do
- val <- readIORef ref
+ val <- liftIO $ readIORef ref
f <- _get_call args
new_val <- f $ [val] ++ (tail args)
- _ <- writeIORef ref $ new_val
+ _ <- liftIO $ writeIORef ref $ new_val
return new_val
ns = [
("=", _func equal_Q),
+ ("throw", _func throw),
("nil?", _func $ run_1 $ _nil_Q),
("true?", _func $ run_1 $ _true_Q),
("false?", _func $ run_1 $ _false_Q),
- ("symbol", _func $ run_1 $ symbol),
+ ("symbol", _func $ symbol),
("symbol?", _func $ run_1 $ _symbol_Q),
- ("keyword", _func $ run_1 $ keyword),
+ ("keyword", _func $ keyword),
("keyword?", _func $ run_1 $ _keyword_Q),
("pr-str", _func pr_str),
@@ -273,7 +283,7 @@ ns = [
("first", _func $ run_1 $ first),
("rest", _func $ run_1 $ rest),
("empty?", _func $ run_1 $ empty_Q),
- ("count", _func $ run_1 $ count),
+ ("count", _func $ count),
("conj", _func $ conj),
("apply", _func $ apply),
("map", _func $ do_map),
diff --git a/haskell/Env.hs b/haskell/Env.hs
index 6a9e6d7..3dfd2c8 100644
--- a/haskell/Env.hs
+++ b/haskell/Env.hs
@@ -34,17 +34,6 @@ env_bind envRef binds exprs = do
(MalList (drop idx exprs) Nil)
return envRef
-{-
-isBound :: Env -> MalVal -> IO Bool
---isBound envRef var = readIORef envRef >>= return . maybe False (const True) . lookup var
-isBound envRef (MalSymbol key) = do
- e <- readIORef envRef
- case e of
- EnvPair (o,m) -> case Map.lookup key m of
- Nothing -> return False
- Just _ -> return True
--}
-
env_find :: Env -> MalVal -> IO (Maybe Env)
env_find envRef sym@(MalSymbol key) = do
e <- readIORef envRef
@@ -55,16 +44,16 @@ env_find envRef sym@(MalSymbol key) = do
Just o -> env_find o sym
Just val -> return $ Just envRef
-env_get :: Env -> MalVal -> IO MalVal
+env_get :: Env -> MalVal -> IOThrows MalVal
env_get envRef sym@(MalSymbol key) = do
e1 <- liftIO $ env_find envRef sym
case e1 of
- Nothing -> error $ "'" ++ key ++ "' not found"
+ Nothing -> throwStr $ "'" ++ key ++ "' not found"
Just eRef -> do
e2 <- liftIO $ readIORef eRef
case e2 of
EnvPair (o,m) -> case Map.lookup key m of
- Nothing -> error $ "env_get error"
+ Nothing -> throwStr $ "env_get error"
Just val -> return val
diff --git a/haskell/Reader.hs b/haskell/Reader.hs
index 377c2f4..91ce63d 100644
--- a/haskell/Reader.hs
+++ b/haskell/Reader.hs
@@ -149,7 +149,7 @@ read_form = do
<|> read_atom
return $ x
-read_str :: String -> IO MalVal
+read_str :: String -> IOThrows MalVal
read_str str = case parse read_form "Mal" str of
- Left err -> error $ show err
+ Left err -> throwStr $ show err
Right val -> return val
diff --git a/haskell/Readline.hs b/haskell/Readline.hs
index 483c827..bbde009 100644
--- a/haskell/Readline.hs
+++ b/haskell/Readline.hs
@@ -10,6 +10,8 @@ import qualified System.Console.Readline as RL
import System.Directory (getHomeDirectory)
+import System.IO (hGetLine, hFlush, hIsEOF, stdin, stdout)
+
history_file = do
home <- getHomeDirectory
return $ home ++ "/.mal-history"
diff --git a/haskell/Types.hs b/haskell/Types.hs
index 6141250..5a7fff7 100644
--- a/haskell/Types.hs
+++ b/haskell/Types.hs
@@ -1,7 +1,7 @@
module Types
-(MalVal (..), Fn (..), EnvData (..), Env,
- _get_call, _to_list,
- catchAny, _func, _malfunc,
+(MalVal (..), MalError (..), IOThrows (..), Fn (..), EnvData (..), Env,
+ throwStr, throwMalVal, _get_call, _to_list,
+ _func, _malfunc,
_nil_Q, _true_Q, _false_Q, _symbol_Q, _keyword_Q,
_list_Q, _vector_Q, _hash_map_Q, _atom_Q)
where
@@ -9,10 +9,11 @@ where
import Data.IORef (IORef)
import qualified Data.Map as Map
import Control.Exception as CE
+import Control.Monad.Error (ErrorT, Error, noMsg, strMsg, throwError)
-- Base Mal types --
-newtype Fn = Fn ([MalVal] -> IO MalVal)
+newtype Fn = Fn ([MalVal] -> IOThrows MalVal)
data MalVal = Nil
| MalFalse
| MalTrue
@@ -48,6 +49,20 @@ instance Eq MalVal where
x == y = _equal_Q x y
+--- Errors/Exceptions ---
+
+data MalError = StringError String
+ | MalValError MalVal
+
+type IOThrows = ErrorT MalError IO
+
+instance Error MalError where
+ noMsg = StringError "An error has occurred"
+ strMsg = StringError
+
+throwStr str = throwError $ StringError str
+throwMalVal mv = throwError $ MalValError mv
+
-- Env types --
-- Note: Env functions are in Env module
data EnvData = EnvPair (Maybe Env, (Map.Map String MalVal))
@@ -61,17 +76,16 @@ type Env = IORef EnvData
_get_call ((Func (Fn f) _) : _) = return f
_get_call (MalFunc {fn=(Fn f)} : _) = return f
-_get_call _ = error $ "first parameter is not a function "
+_get_call _ = throwStr "_get_call first parameter is not a function "
_to_list (MalList lst _) = return lst
_to_list (MalVector lst _) = return lst
-_to_list _ = error $ "expected a MalList or MalVector"
+_to_list _ = throwStr "_to_list expected a MalList or MalVector"
-- Errors
-catchAny :: IO a -> (CE.SomeException -> IO a) -> IO a
-catchAny = CE.catch
-
+--catchAny :: IO a -> (CE.SomeException -> IO a) -> IO a
+--catchAny = CE.catch
-- Functions
diff --git a/haskell/step0_repl.hs b/haskell/step0_repl.hs
index ab83602..6396400 100644
--- a/haskell/step0_repl.hs
+++ b/haskell/step0_repl.hs
@@ -1,4 +1,4 @@
-import Control.Monad
+import System.IO (hFlush, stdout)
import Readline (readline, load_history)
diff --git a/haskell/step1_read_print.hs b/haskell/step1_read_print.hs
index 70bfee6..c7a4eef 100644
--- a/haskell/step1_read_print.hs
+++ b/haskell/step1_read_print.hs
@@ -1,5 +1,5 @@
-import Control.Monad (when)
-import Control.Monad.Error (throwError)
+import System.IO (hFlush, stdout)
+import Control.Monad.Error (runErrorT)
import Readline (readline, load_history)
import Types
@@ -7,7 +7,7 @@ import Reader (read_str)
import Printer (_pr_str)
-- read
-mal_read :: String -> IO MalVal
+mal_read :: String -> IOThrows MalVal
mal_read str = read_str str
-- eval
@@ -19,7 +19,7 @@ mal_print :: MalVal -> String
mal_print exp = show exp
-- repl
-rep :: String -> IO String
+rep :: String -> IOThrows String
rep line = do
ast <- mal_read line
return $ mal_print (eval ast "")
@@ -31,9 +31,13 @@ repl_loop = do
Nothing -> return ()
Just "" -> repl_loop
Just str -> do
- out <- catchAny (rep str) $ \e -> do
- return $ "Error: " ++ (show e)
+ res <- runErrorT $ rep 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
main = do
diff --git a/haskell/step2_eval.hs b/haskell/step2_eval.hs
index bdc7d28..9105737 100644
--- a/haskell/step2_eval.hs
+++ b/haskell/step2_eval.hs
@@ -1,5 +1,6 @@
-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 qualified Data.Map as Map
import qualified Data.Traversable as DT
@@ -9,14 +10,14 @@ import Reader (read_str)
import Printer (_pr_str)
-- read
-mal_read :: String -> IO MalVal
+mal_read :: String -> IOThrows MalVal
mal_read str = read_str str
-- eval
-eval_ast :: MalVal -> (Map.Map String MalVal) -> IO MalVal
+eval_ast :: MalVal -> (Map.Map String MalVal) -> IOThrows MalVal
eval_ast (MalSymbol sym) env = do
case Map.lookup sym env of
- Nothing -> error $ "'" ++ sym ++ "' not found"
+ Nothing -> throwStr $ "'" ++ sym ++ "' not found"
Just v -> return v
eval_ast ast@(MalList lst m) env = do
new_lst <- mapM (\x -> (eval x env)) lst
@@ -29,16 +30,16 @@ eval_ast ast@(MalHashMap lst m) env = do
return $ MalHashMap new_hm m
eval_ast ast env = return ast
-apply_ast :: MalVal -> (Map.Map String MalVal) -> IO MalVal
+apply_ast :: MalVal -> (Map.Map String MalVal) -> IOThrows MalVal
apply_ast ast@(MalList _ _) env = do
el <- eval_ast ast env
case el of
(MalList ((Func (Fn f) _) : rest) _) ->
f $ rest
el ->
- error $ "invalid apply: " ++ (show el)
+ throwStr $ "invalid apply: " ++ (show el)
-eval :: MalVal -> (Map.Map String MalVal) -> IO MalVal
+eval :: MalVal -> (Map.Map String MalVal) -> IOThrows MalVal
eval ast env = do
case ast of
(MalList _ _) -> apply_ast ast env
@@ -51,13 +52,13 @@ mal_print exp = show exp
-- repl
add [MalNumber a, MalNumber b] = return $ MalNumber $ a + b
-add _ = error $ "illegal arguments to +"
+add _ = throwStr $ "illegal arguments to +"
sub [MalNumber a, MalNumber b] = return $ MalNumber $ a - b
-sub _ = error $ "illegal arguments to -"
+sub _ = throwStr $ "illegal arguments to -"
mult [MalNumber a, MalNumber b] = return $ MalNumber $ a * b
-mult _ = error $ "illegal arguments to *"
+mult _ = throwStr $ "illegal arguments to *"
divd [MalNumber a, MalNumber b] = return $ MalNumber $ a `div` b
-divd _ = error $ "illegal arguments to /"
+divd _ = throwStr $ "illegal arguments to /"
repl_env :: Map.Map String MalVal
repl_env = Map.fromList [("+", _func add),
@@ -65,7 +66,7 @@ repl_env = Map.fromList [("+", _func add),
("*", _func mult),
("/", _func divd)]
-rep :: String -> IO String
+rep :: String -> IOThrows String
rep line = do
ast <- mal_read line
exp <- eval ast repl_env
@@ -78,9 +79,13 @@ repl_loop = do
Nothing -> return ()
Just "" -> repl_loop
Just str -> do
- out <- catchAny (rep str) $ \e -> do
- return $ "Error: " ++ (show e)
+ res <- runErrorT $ rep 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
main = do
diff --git a/haskell/step3_env.hs b/haskell/step3_env.hs
index 6f65afd..3bd3b19 100644
--- a/haskell/step3_env.hs
+++ b/haskell/step3_env.hs
@@ -1,5 +1,7 @@
-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
@@ -10,11 +12,11 @@ import Printer (_pr_str)
import Env (Env, env_new, env_get, env_set)
-- 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
@@ -27,37 +29,37 @@ eval_ast ast@(MalHashMap lst m) env = do
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 _ _) env = do
el <- eval_ast ast env
case el of
(MalList ((Func (Fn f) _) : rest) _) ->
f $ rest
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
@@ -70,15 +72,15 @@ mal_print exp = show exp
-- repl
add [MalNumber a, MalNumber b] = return $ MalNumber $ a + b
-add _ = error $ "illegal arguments to +"
+add _ = throwStr $ "illegal arguments to +"
sub [MalNumber a, MalNumber b] = return $ MalNumber $ a - b
-sub _ = error $ "illegal arguments to -"
+sub _ = throwStr $ "illegal arguments to -"
mult [MalNumber a, MalNumber b] = return $ MalNumber $ a * b
-mult _ = error $ "illegal arguments to *"
+mult _ = throwStr $ "illegal arguments to *"
divd [MalNumber a, MalNumber b] = return $ MalNumber $ a `div` b
-divd _ = error $ "illegal arguments to /"
+divd _ = throwStr $ "illegal arguments to /"
-rep :: Env -> String -> IO String
+rep :: Env -> String -> IOThrows String
rep env line = do
ast <- mal_read line
exp <- eval ast env
@@ -91,9 +93,13 @@ repl_loop env = do
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
diff --git a/haskell/step4_if_fn_do.hs b/haskell/step4_if_fn_do.hs
index 4630146..497ece2 100644
--- a/haskell/step4_if_fn_do.hs
+++ b/haskell/step4_if_fn_do.hs
@@ -1,5 +1,7 @@
-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
@@ -11,11 +13,11 @@ import Env (Env, env_new, env_bind, env_get, env_set)
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
@@ -28,28 +30,28 @@ eval_ast ast@(MalHashMap lst m) env = do
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
@@ -70,26 +72,26 @@ apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
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 $ (_func
(\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
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
@@ -102,7 +104,7 @@ mal_print exp = show exp
-- repl
-rep :: Env -> String -> IO String
+rep :: Env -> String -> IOThrows String
rep env line = do
ast <- mal_read line
exp <- eval ast env
@@ -115,9 +117,13 @@ repl_loop env = do
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
@@ -129,6 +135,6 @@ 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
diff --git a/haskell/step5_tco.hs b/haskell/step5_tco.hs
index db34c23..f32875a 100644
--- a/haskell/step5_tco.hs
+++ b/haskell/step5_tco.hs
@@ -1,5 +1,7 @@
-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
@@ -11,11 +13,11 @@ import Env (Env, env_new, env_bind, env_get, env_set)
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
@@ -28,28 +30,28 @@ eval_ast ast@(MalHashMap lst m) env = do
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
@@ -70,30 +72,30 @@ apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
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
@@ -106,7 +108,7 @@ mal_print exp = show exp
-- repl
-rep :: Env -> String -> IO String
+rep :: Env -> String -> IOThrows String
rep env line = do
ast <- mal_read line
exp <- eval ast env
@@ -119,9 +121,13 @@ repl_loop env = do
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
@@ -133,6 +139,6 @@ 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
diff --git a/haskell/step6_file.hs b/haskell/step6_file.hs
index 532991a..ba58f2f 100644
--- a/haskell/step6_file.hs
+++ b/haskell/step6_file.hs
@@ -1,6 +1,8 @@
+import System.IO (hFlush, stdout)
import System.Environment (getArgs)
-import Control.Monad (when, mapM)
-import Control.Monad.Error (throwError)
+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
@@ -12,11 +14,11 @@ import Env (Env, env_new, env_bind, env_get, env_set)
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
@@ -29,28 +31,28 @@ eval_ast ast@(MalHashMap lst m) env = do
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
@@ -71,30 +73,30 @@ apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
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
@@ -107,7 +109,7 @@ mal_print exp = show exp
-- repl
-rep :: Env -> String -> IO String
+rep :: Env -> String -> IOThrows String
rep env line = do
ast <- mal_read line
exp <- eval ast env
@@ -120,9 +122,13 @@ repl_loop env = do
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
@@ -137,12 +143,12 @@ main = do
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) \")\")))))"
+ runErrorT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
+ runErrorT $ 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)) Nil)
- rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
+ runErrorT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
return ()
else
repl_loop repl_env
diff --git a/haskell/step7_quote.hs b/haskell/step7_quote.hs
index e8d8a53..c6bb0e0 100644
--- a/haskell/step7_quote.hs
+++ b/haskell/step7_quote.hs
@@ -1,6 +1,8 @@
+import System.IO (hFlush, stdout)
import System.Environment (getArgs)
-import Control.Monad (when, mapM)
-import Control.Monad.Error (throwError)
+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
@@ -12,7 +14,7 @@ import Env (Env, env_new, env_bind, env_get, env_set)
import Core as Core
-- read
-mal_read :: String -> IO MalVal
+mal_read :: String -> IOThrows MalVal
mal_read str = read_str str
-- eval
@@ -37,7 +39,7 @@ quasiquote ast =
_ -> MalList [(MalSymbol "quote"), ast] Nil
-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
@@ -50,36 +52,36 @@ eval_ast ast@(MalHashMap lst m) env = do
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 "quote" : args) _) env = do
case args of
a1 : [] -> return a1
- _ -> error $ "invalid quote"
+ _ -> throwStr "invalid quote"
apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do
case args of
a1 : [] -> eval (quasiquote a1) env
- _ -> error $ "invalid quasiquote"
+ _ -> throwStr "invalid quasiquote"
apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
case args of
([]) -> return Nil
@@ -100,30 +102,30 @@ apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
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
@@ -136,7 +138,7 @@ mal_print exp = show exp
-- repl
-rep :: Env -> String -> IO String
+rep :: Env -> String -> IOThrows String
rep env line = do
ast <- mal_read line
exp <- eval ast env
@@ -149,9 +151,13 @@ repl_loop env = do
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
@@ -166,12 +172,12 @@ main = do
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) \")\")))))"
+ runErrorT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
+ runErrorT $ 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)) Nil)
- rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
+ runErrorT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
return ()
else
repl_loop repl_env
diff --git a/haskell/step8_macros.hs b/haskell/step8_macros.hs
index 3ad955b..9b272e8 100644
--- a/haskell/step8_macros.hs
+++ b/haskell/step8_macros.hs
@@ -1,6 +1,8 @@
+import System.IO (hFlush, stdout)
import System.Environment (getArgs)
-import Control.Monad (when, mapM)
-import Control.Monad.Error (throwError)
+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
@@ -12,7 +14,7 @@ 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 :: String -> IOThrows MalVal
mal_read str = read_str str
-- eval
@@ -36,9 +38,9 @@ quasiquote ast =
quasiquote (MalVector rest Nil)] Nil
_ -> MalList [(MalSymbol "quote"), ast] Nil
-is_macro_call :: MalVal -> Env -> IO Bool
+is_macro_call :: MalVal -> Env -> IOThrows Bool
is_macro_call (MalList (a0@(MalSymbol _) : rest) _) env = do
- e <- env_find env a0
+ e <- liftIO $ env_find env a0
case e of
Just e -> do
f <- env_get e a0
@@ -48,7 +50,7 @@ is_macro_call (MalList (a0@(MalSymbol _) : rest) _) env = do
Nothing -> return False
is_macro_call _ _ = return False
-macroexpand :: MalVal -> Env -> IO MalVal
+macroexpand :: MalVal -> Env -> IOThrows MalVal
macroexpand ast@(MalList (a0 : args) _) env = do
mc <- is_macro_call ast env
if mc then do
@@ -63,8 +65,7 @@ macroexpand ast@(MalList (a0 : args) _) env = do
return ast
macroexpand ast _ = return ast
-
-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
@@ -77,36 +78,36 @@ eval_ast ast@(MalHashMap lst m) env = do
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 "quote" : args) _) env = do
case args of
a1 : [] -> return a1
- _ -> error $ "invalid quote"
+ _ -> throwStr "invalid quote"
apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do
case args of
a1 : [] -> eval (quasiquote a1) env
- _ -> error $ "invalid quasiquote"
+ _ -> throwStr "invalid quasiquote"
apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = do
case args of
@@ -117,13 +118,13 @@ apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = 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!"
+ liftIO $ env_set env a1 new_func
+ _ -> throwStr "defmacro! on non-function"
+ _ -> throwStr "invalid defmacro!"
apply_ast ast@(MalList (MalSymbol "macroexpand" : args) _) env = do
case args of
(a1 : []) -> macroexpand a1 env
- _ -> error $ "invalid macroexpand"
+ _ -> throwStr "invalid macroexpand"
apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
case args of
([]) -> return Nil
@@ -144,17 +145,17 @@ apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
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
mc <- is_macro_call ast env
if mc then do
@@ -170,14 +171,14 @@ apply_ast ast@(MalList _ _) env = 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)
+ 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)
_ -> return ast
-eval :: MalVal -> Env -> IO MalVal
+eval :: MalVal -> Env -> IOThrows MalVal
eval ast env = do
case ast of
(MalList _ _) -> apply_ast ast env
@@ -190,7 +191,7 @@ mal_print exp = show exp
-- repl
-rep :: Env -> String -> IO String
+rep :: Env -> String -> IOThrows String
rep env line = do
ast <- mal_read line
exp <- eval ast env
@@ -203,9 +204,13 @@ repl_loop env = do
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
@@ -220,14 +225,14 @@ main = do
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))))))))"
+ runErrorT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
+ runErrorT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
+ runErrorT $ 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)))))))"
+ runErrorT $ 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) ++ "\")"
+ runErrorT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
return ()
else
repl_loop repl_env
diff --git a/haskell/step9_try.hs b/haskell/step9_try.hs
index 3ad955b..f944d17 100644
--- a/haskell/step9_try.hs
+++ b/haskell/step9_try.hs
@@ -1,6 +1,8 @@
+import System.IO (hFlush, stdout)
import System.Environment (getArgs)
-import Control.Monad (when, mapM)
-import Control.Monad.Error (throwError)
+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
@@ -12,7 +14,7 @@ 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 :: String -> IOThrows MalVal
mal_read str = read_str str
-- eval
@@ -36,9 +38,9 @@ quasiquote ast =
quasiquote (MalVector rest Nil)] Nil
_ -> MalList [(MalSymbol "quote"), ast] Nil
-is_macro_call :: MalVal -> Env -> IO Bool
+is_macro_call :: MalVal -> Env -> IOThrows Bool
is_macro_call (MalList (a0@(MalSymbol _) : rest) _) env = do
- e <- env_find env a0
+ e <- liftIO $ env_find env a0
case e of
Just e -> do
f <- env_get e a0
@@ -48,7 +50,7 @@ is_macro_call (MalList (a0@(MalSymbol _) : rest) _) env = do
Nothing -> return False
is_macro_call _ _ = return False
-macroexpand :: MalVal -> Env -> IO MalVal
+macroexpand :: MalVal -> Env -> IOThrows MalVal
macroexpand ast@(MalList (a0 : args) _) env = do
mc <- is_macro_call ast env
if mc then do
@@ -63,8 +65,7 @@ macroexpand ast@(MalList (a0 : args) _) env = do
return ast
macroexpand ast _ = return ast
-
-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
@@ -77,36 +78,36 @@ eval_ast ast@(MalHashMap lst m) env = do
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 "quote" : args) _) env = do
case args of
a1 : [] -> return a1
- _ -> error $ "invalid quote"
+ _ -> throwStr "invalid quote"
apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do
case args of
a1 : [] -> eval (quasiquote a1) env
- _ -> error $ "invalid quasiquote"
+ _ -> throwStr "invalid quasiquote"
apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = do
case args of
@@ -117,13 +118,28 @@ apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = 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!"
+ liftIO $ env_set env a1 new_func
+ _ -> throwStr "defmacro! on non-function"
+ _ -> throwStr "invalid defmacro!"
apply_ast ast@(MalList (MalSymbol "macroexpand" : args) _) env = do
case args of
(a1 : []) -> macroexpand a1 env
- _ -> error $ "invalid macroexpand"
+ _ -> throwStr "invalid macroexpand"
+apply_ast ast@(MalList (MalSymbol "try*" : args) _) env = do
+ case args of
+ (a1 : []) -> eval a1 env
+ (a1 : (MalList ((MalSymbol "catch*") : a21 : a22 : []) _) : []) -> do
+ res <- liftIO $ runErrorT $ eval a1 env
+ case res of
+ Right val -> return val
+ Left err -> do
+ exc <- case err of
+ (StringError str) -> return $ MalString str
+ (MalValError mv) -> return $ mv
+ try_env <- liftIO $ env_new $ Just env
+ liftIO $ env_set try_env a21 exc
+ eval a22 try_env
+ _ -> throwStr "invalid try*"
apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
case args of
([]) -> return Nil
@@ -144,17 +160,17 @@ apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
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
mc <- is_macro_call ast env
if mc then do
@@ -170,14 +186,14 @@ apply_ast ast@(MalList _ _) env = 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)
+ 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)
_ -> return ast
-eval :: MalVal -> Env -> IO MalVal
+eval :: MalVal -> Env -> IOThrows MalVal
eval ast env = do
case ast of
(MalList _ _) -> apply_ast ast env
@@ -190,7 +206,7 @@ mal_print exp = show exp
-- repl
-rep :: Env -> String -> IO String
+rep :: Env -> String -> IOThrows String
rep env line = do
ast <- mal_read line
exp <- eval ast env
@@ -203,9 +219,13 @@ repl_loop env = do
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
@@ -220,14 +240,14 @@ main = do
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))))))))"
+ runErrorT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
+ runErrorT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
+ runErrorT $ 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)))))))"
+ runErrorT $ 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) ++ "\")"
+ runErrorT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
return ()
else
repl_loop repl_env
diff --git a/haskell/stepA_interop.hs b/haskell/stepA_interop.hs
index 597df77..f1d4b38 100644
--- a/haskell/stepA_interop.hs
+++ b/haskell/stepA_interop.hs
@@ -1,6 +1,8 @@
+import System.IO (hFlush, stdout)
import System.Environment (getArgs)
-import Control.Monad (when, mapM)
-import Control.Monad.Error (throwError)
+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
@@ -12,7 +14,7 @@ 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 :: String -> IOThrows MalVal
mal_read str = read_str str
-- eval
@@ -36,9 +38,9 @@ quasiquote ast =
quasiquote (MalVector rest Nil)] Nil
_ -> MalList [(MalSymbol "quote"), ast] Nil
-is_macro_call :: MalVal -> Env -> IO Bool
+is_macro_call :: MalVal -> Env -> IOThrows Bool
is_macro_call (MalList (a0@(MalSymbol _) : rest) _) env = do
- e <- env_find env a0
+ e <- liftIO $ env_find env a0
case e of
Just e -> do
f <- env_get e a0
@@ -48,7 +50,7 @@ is_macro_call (MalList (a0@(MalSymbol _) : rest) _) env = do
Nothing -> return False
is_macro_call _ _ = return False
-macroexpand :: MalVal -> Env -> IO MalVal
+macroexpand :: MalVal -> Env -> IOThrows MalVal
macroexpand ast@(MalList (a0 : args) _) env = do
mc <- is_macro_call ast env
if mc then do
@@ -63,8 +65,7 @@ macroexpand ast@(MalList (a0 : args) _) env = do
return ast
macroexpand ast _ = return ast
-
-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
@@ -77,36 +78,36 @@ eval_ast ast@(MalHashMap lst m) env = do
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 "quote" : args) _) env = do
case args of
a1 : [] -> return a1
- _ -> error $ "invalid quote"
+ _ -> throwStr "invalid quote"
apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do
case args of
a1 : [] -> eval (quasiquote a1) env
- _ -> error $ "invalid quasiquote"
+ _ -> throwStr "invalid quasiquote"
apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = do
case args of
@@ -117,13 +118,28 @@ apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = 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!"
+ liftIO $ env_set env a1 new_func
+ _ -> throwStr "defmacro! on non-function"
+ _ -> throwStr "invalid defmacro!"
apply_ast ast@(MalList (MalSymbol "macroexpand" : args) _) env = do
case args of
(a1 : []) -> macroexpand a1 env
- _ -> error $ "invalid macroexpand"
+ _ -> throwStr "invalid macroexpand"
+apply_ast ast@(MalList (MalSymbol "try*" : args) _) env = do
+ case args of
+ (a1 : []) -> eval a1 env
+ (a1 : (MalList ((MalSymbol "catch*") : a21 : a22 : []) _) : []) -> do
+ res <- liftIO $ runErrorT $ eval a1 env
+ case res of
+ Right val -> return val
+ Left err -> do
+ exc <- case err of
+ (StringError str) -> return $ MalString str
+ (MalValError mv) -> return $ mv
+ try_env <- liftIO $ env_new $ Just env
+ liftIO $ env_set try_env a21 exc
+ eval a22 try_env
+ _ -> throwStr "invalid try*"
apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
case args of
([]) -> return Nil
@@ -144,17 +160,17 @@ apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
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
mc <- is_macro_call ast env
if mc then do
@@ -170,14 +186,14 @@ apply_ast ast@(MalList _ _) env = 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)
+ 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)
_ -> return ast
-eval :: MalVal -> Env -> IO MalVal
+eval :: MalVal -> Env -> IOThrows MalVal
eval ast env = do
case ast of
(MalList _ _) -> apply_ast ast env
@@ -190,7 +206,7 @@ mal_print exp = show exp
-- repl
-rep :: Env -> String -> IO String
+rep :: Env -> String -> IOThrows String
rep env line = do
ast <- mal_read line
exp <- eval ast env
@@ -203,9 +219,13 @@ repl_loop env = do
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
@@ -220,16 +240,16 @@ main = do
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))))))))"
+ runErrorT $ rep repl_env "(def! *host-language* \"haskell\")"
+ runErrorT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
+ runErrorT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
+ runErrorT $ 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)))))))"
+ runErrorT $ 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) ++ "\")"
+ runErrorT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
return ()
else do
- rep repl_env "(println (str \"Mal [\" *host-language* \"]\"))"
+ runErrorT $ rep repl_env "(println (str \"Mal [\" *host-language* \"]\"))"
repl_loop repl_env
generated by cgit v1.2.3 (git 2.25.1) at 2026-01-06 07:23:58 +0000