mirror of
https://github.com/kanaka/mal.git
synced 2024-09-11 13:55:55 +03:00
Haskell: add error handling and try*/catch*.
Achieve self-hosting!
This commit is contained in:
parent
c150ec41f4
commit
5400d4bf5e
@ -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
104
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),
|
||||
|
@ -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
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
@ -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"
|
||||
|
@ -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
|
||||
|
||||
|
@ -1,4 +1,4 @@
|
||||
import Control.Monad
|
||||
import System.IO (hFlush, stdout)
|
||||
|
||||
import Readline (readline, load_history)
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user