kanaka/mal
1
1
Fork 0
mirror of https://github.com/kanaka/mal.git synced 2024-09-11 13:55:55 +03:00
Code Issues Projects Releases Wiki Activity

Haskell: add error handling and try*/catch*.

Browse Source 
Achieve self-hosting!
This commit is contained in:
Joel Martin 2014-12-24 23:17:38 -07:00
parent c150ec41f4
commit 5400d4bf5e
17 changed files with 425 additions and 324 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
README.md
View File

@ -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

104
haskell/Core.hs
View File

@ -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),

17
haskell/Env.hs
View File

@ -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

4
haskell/Reader.hs
View File

@ -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

2
haskell/Readline.hs
View File

@ -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"

32
haskell/Types.hs
View File

@ -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

2
haskell/step0_repl.hs
View File

@ -1,4 +1,4 @@
import Control.Monad
import System.IO (hFlush, stdout)
import Readline (readline, load_history)

16
haskell/step1_read_print.hs
View File

@ -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

35
haskell/step2_eval.hs
View File

@ -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

46
haskell/step3_env.hs
View File

@ -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

48
haskell/step4_if_fn_do.hs
View File

@ -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

52
haskell/step5_tco.hs
View File

@ -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

56
haskell/step6_file.hs
View File

@ -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

60
haskell/step7_quote.hs
View File

@ -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

79
haskell/step8_macros.hs
View File

@ -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

94
haskell/step9_try.hs
View File

@ -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

98
haskell/stepA_interop.hs
View File

@ -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