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

Support GHC 7.10.1+. Update error handling

Browse Source
This commit is contained in:
Prat 2016-10-02 13:49:28 -04:00
parent 49762e14b2
commit 53db2d63cb
12 changed files with 74 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
haskell/Core.hs
View File

@ -275,7 +275,7 @@ ns = [
("*", _func $ num_op (*)),
("/", _func $ num_op (div)),
("time-ms", _func $ time_ms),
("list", _func $ list),
("list?", _func $ run_1 _list_Q),
("vector", _func $ vector),

10
haskell/Types.hs
View File

@ -9,7 +9,7 @@ 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)
import Control.Monad.Except
-- Base Mal types --
@ -55,13 +55,11 @@ instance Eq MalVal where
data MalError = StringError String
| MalValError MalVal
type IOThrows = ErrorT MalError IO
instance Error MalError where
noMsg = StringError "An error has occurred"
strMsg = StringError
type IOThrows = ExceptT MalError IO
throwStr :: String -> IOThrows a
throwStr str = throwError $ StringError str
throwMalVal :: MalVal -> IOThrows a
throwMalVal mv = throwError $ MalValError mv
-- Env types --

4
haskell/step1_read_print.hs
View File

@ -1,5 +1,5 @@
import System.IO (hFlush, stdout)
import Control.Monad.Error (runErrorT)
import Control.Monad.Except (runExceptT)
import Readline (readline, load_history)
import Types
@ -31,7 +31,7 @@ repl_loop = do
Nothing -> return ()
Just "" -> repl_loop
Just str -> do
res <- runErrorT $ rep str
res <- runExceptT $ rep str
out <- case res of
Left (StringError str) -> return $ "Error: " ++ str
Left (MalValError mv) -> return $ "Error: " ++ (show mv)

4
haskell/step2_eval.hs
View File

@ -1,6 +1,6 @@
import System.IO (hFlush, stdout)
import Control.Monad (mapM)
import Control.Monad.Error (runErrorT)
import Control.Monad.Except (runExceptT)
import qualified Data.Map as Map
import qualified Data.Traversable as DT
@ -81,7 +81,7 @@ repl_loop = do
Nothing -> return ()
Just "" -> repl_loop
Just str -> do
res <- runErrorT $ rep str
res <- runExceptT $ rep str
out <- case res of
Left (StringError str) -> return $ "Error: " ++ str
Left (MalValError mv) -> return $ "Error: " ++ (show mv)

4
haskell/step3_env.hs
View File

@ -1,6 +1,6 @@
import System.IO (hFlush, stdout)
import Control.Monad (mapM)
import Control.Monad.Error (runErrorT)
import Control.Monad.Except (runExceptT)
import Control.Monad.Trans (liftIO)
import qualified Data.Map as Map
import qualified Data.Traversable as DT
@ -95,7 +95,7 @@ repl_loop env = do
Nothing -> return ()
Just "" -> repl_loop env
Just str -> do
res <- runErrorT $ rep env str
res <- runExceptT $ rep env str
out <- case res of
Left (StringError str) -> return $ "Error: " ++ str
Left (MalValError mv) -> return $ "Error: " ++ (show mv)

8
haskell/step4_if_fn_do.hs
View File

@ -1,6 +1,6 @@
import System.IO (hFlush, stdout)
import Control.Monad (mapM)
import Control.Monad.Error (runErrorT)
import Control.Monad.Except (runExceptT)
import Control.Monad.Trans (liftIO)
import qualified Data.Map as Map
import qualified Data.Traversable as DT
@ -61,7 +61,7 @@ apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
el <- eval_ast (MalList args Nil) env
case el of
(MalList lst _) -> return $ last lst
apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
case args of
(a1 : a2 : a3 : []) -> do
@ -119,7 +119,7 @@ repl_loop env = do
Nothing -> return ()
Just "" -> repl_loop env
Just str -> do
res <- runErrorT $ rep env str
res <- runExceptT $ rep env str
out <- case res of
Left (StringError str) -> return $ "Error: " ++ str
Left (MalValError mv) -> return $ "Error: " ++ (show mv)
@ -137,6 +137,6 @@ main = do
(mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns)
-- core.mal: defined using the language itself
runErrorT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
runExceptT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
repl_loop repl_env

8
haskell/step5_tco.hs
View File

@ -1,6 +1,6 @@
import System.IO (hFlush, stdout)
import Control.Monad (mapM)
import Control.Monad.Error (runErrorT)
import Control.Monad.Except (runExceptT)
import Control.Monad.Trans (liftIO)
import qualified Data.Map as Map
import qualified Data.Traversable as DT
@ -61,7 +61,7 @@ apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
el <- eval_ast (MalList args Nil) env
case el of
(MalList lst _) -> return $ last lst
apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
case args of
(a1 : a2 : a3 : []) -> do
@ -123,7 +123,7 @@ repl_loop env = do
Nothing -> return ()
Just "" -> repl_loop env
Just str -> do
res <- runErrorT $ rep env str
res <- runExceptT $ rep env str
out <- case res of
Left (StringError str) -> return $ "Error: " ++ str
Left (MalValError mv) -> return $ "Error: " ++ (show mv)
@ -141,6 +141,6 @@ main = do
(mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns)
-- core.mal: defined using the language itself
runErrorT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
runExceptT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
repl_loop repl_env

14
haskell/step6_file.hs
View File

@ -1,7 +1,7 @@
import System.IO (hFlush, stdout)
import System.Environment (getArgs)
import Control.Monad (mapM)
import Control.Monad.Error (runErrorT)
import Control.Monad.Except (runExceptT)
import Control.Monad.Trans (liftIO)
import qualified Data.Map as Map
import qualified Data.Traversable as DT
@ -62,7 +62,7 @@ apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
el <- eval_ast (MalList args Nil) env
case el of
(MalList lst _) -> return $ last lst
apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
case args of
(a1 : a2 : a3 : []) -> do
@ -124,7 +124,7 @@ repl_loop env = do
Nothing -> return ()
Just "" -> repl_loop env
Just str -> do
res <- runErrorT $ rep env str
res <- runExceptT $ rep env str
out <- case res of
Left (StringError str) -> return $ "Error: " ++ str
Left (MalValError mv) -> return $ "Error: " ++ (show mv)
@ -145,12 +145,12 @@ main = do
env_set repl_env (MalSymbol "*ARGV*") (MalList [] Nil)
-- core.mal: defined using the language itself
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) \")\")))))"
runExceptT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
runExceptT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
if length args > 0 then do
env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)) Nil)
runErrorT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
runExceptT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
return ()
else
else
repl_loop repl_env

14
haskell/step7_quote.hs
View File

@ -1,7 +1,7 @@
import System.IO (hFlush, stdout)
import System.Environment (getArgs)
import Control.Monad (mapM)
import Control.Monad.Error (runErrorT)
import Control.Monad.Except (runExceptT)
import Control.Monad.Trans (liftIO)
import qualified Data.Map as Map
import qualified Data.Traversable as DT
@ -91,7 +91,7 @@ apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
el <- eval_ast (MalList args Nil) env
case el of
(MalList lst _) -> return $ last lst
apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
case args of
(a1 : a2 : a3 : []) -> do
@ -153,7 +153,7 @@ repl_loop env = do
Nothing -> return ()
Just "" -> repl_loop env
Just str -> do
res <- runErrorT $ rep env str
res <- runExceptT $ rep env str
out <- case res of
Left (StringError str) -> return $ "Error: " ++ str
Left (MalValError mv) -> return $ "Error: " ++ (show mv)
@ -174,12 +174,12 @@ main = do
env_set repl_env (MalSymbol "*ARGV*") (MalList [] Nil)
-- core.mal: defined using the language itself
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) \")\")))))"
runExceptT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
runExceptT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
if length args > 0 then do
env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)) Nil)
runErrorT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
runExceptT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
return ()
else
else
repl_loop repl_env

24
haskell/step8_macros.hs
View File

@ -1,7 +1,7 @@
import System.IO (hFlush, stdout)
import System.Environment (getArgs)
import Control.Monad (mapM)
import Control.Monad.Error (runErrorT)
import Control.Monad.Except (runExceptT)
import Control.Monad.Trans (liftIO)
import qualified Data.Map as Map
import qualified Data.Traversable as DT
@ -55,7 +55,7 @@ macroexpand ast@(MalList (a0 : args) _) env = do
mc <- is_macro_call ast env
if mc then do
mac <- env_get env a0
case mac of
case mac of
MalFunc {fn=(Fn f)} -> do
new_ast <- f args
macroexpand new_ast env
@ -122,11 +122,11 @@ apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = do
meta=Nil} in
liftIO $ env_set env a1 new_func
_ -> throwStr "defmacro! on non-function"
_ -> throwStr "invalid defmacro!"
_ -> throwStr "invalid defmacro!"
apply_ast ast@(MalList (MalSymbol "macroexpand" : args) _) env = do
case args of
(a1 : []) -> macroexpand a1 env
_ -> throwStr "invalid macroexpand"
_ -> throwStr "invalid macroexpand"
apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
case args of
([]) -> return Nil
@ -134,7 +134,7 @@ apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
el <- eval_ast (MalList args Nil) env
case el of
(MalList lst _) -> return $ last lst
apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
case args of
(a1 : a2 : a3 : []) -> do
@ -206,7 +206,7 @@ repl_loop env = do
Nothing -> return ()
Just "" -> repl_loop env
Just str -> do
res <- runErrorT $ rep env str
res <- runExceptT $ rep env str
out <- case res of
Left (StringError str) -> return $ "Error: " ++ str
Left (MalValError mv) -> return $ "Error: " ++ (show mv)
@ -227,14 +227,14 @@ main = do
env_set repl_env (MalSymbol "*ARGV*") (MalList [] Nil)
-- core.mal: defined using the language itself
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))))))))"
runExceptT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
runExceptT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
runExceptT $ rep repl_env "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))"
runExceptT $ rep repl_env "(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)
runErrorT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
runExceptT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
return ()
else
else
repl_loop repl_env

26
haskell/step9_try.hs
View File

@ -1,7 +1,7 @@
import System.IO (hFlush, stdout)
import System.Environment (getArgs)
import Control.Monad (mapM)
import Control.Monad.Error (runErrorT)
import Control.Monad.Except (runExceptT)
import Control.Monad.Trans (liftIO)
import qualified Data.Map as Map
import qualified Data.Traversable as DT
@ -55,7 +55,7 @@ macroexpand ast@(MalList (a0 : args) _) env = do
mc <- is_macro_call ast env
if mc then do
mac <- env_get env a0
case mac of
case mac of
MalFunc {fn=(Fn f)} -> do
new_ast <- f args
macroexpand new_ast env
@ -122,16 +122,16 @@ apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = do
meta=Nil} in
liftIO $ env_set env a1 new_func
_ -> throwStr "defmacro! on non-function"
_ -> throwStr "invalid defmacro!"
_ -> throwStr "invalid defmacro!"
apply_ast ast@(MalList (MalSymbol "macroexpand" : args) _) env = do
case args of
(a1 : []) -> macroexpand a1 env
_ -> throwStr "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
res <- liftIO $ runExceptT $ eval a1 env
case res of
Right val -> return val
Left err -> do
@ -149,7 +149,7 @@ apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
el <- eval_ast (MalList args Nil) env
case el of
(MalList lst _) -> return $ last lst
apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
case args of
(a1 : a2 : a3 : []) -> do
@ -221,7 +221,7 @@ repl_loop env = do
Nothing -> return ()
Just "" -> repl_loop env
Just str -> do
res <- runErrorT $ rep env str
res <- runExceptT $ rep env str
out <- case res of
Left (StringError str) -> return $ "Error: " ++ str
Left (MalValError mv) -> return $ "Error: " ++ (show mv)
@ -242,14 +242,14 @@ main = do
env_set repl_env (MalSymbol "*ARGV*") (MalList [] Nil)
-- core.mal: defined using the language itself
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))))))))"
runExceptT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
runExceptT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
runExceptT $ rep repl_env "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))"
runExceptT $ rep repl_env "(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)
runErrorT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
runExceptT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
return ()
else
else
repl_loop repl_env

32
haskell/stepA_mal.hs
View File

@ -1,7 +1,7 @@
import System.IO (hFlush, stdout)
import System.Environment (getArgs)
import Control.Monad (mapM)
import Control.Monad.Error (runErrorT)
import Control.Monad.Except (runExceptT)
import Control.Monad.Trans (liftIO)
import qualified Data.Map as Map
import qualified Data.Traversable as DT
@ -55,7 +55,7 @@ macroexpand ast@(MalList (a0 : args) _) env = do
mc <- is_macro_call ast env
if mc then do
mac <- env_get env a0
case mac of
case mac of
MalFunc {fn=(Fn f)} -> do
new_ast <- f args
macroexpand new_ast env
@ -122,16 +122,16 @@ apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = do
meta=Nil} in
liftIO $ env_set env a1 new_func
_ -> throwStr "defmacro! on non-function"
_ -> throwStr "invalid defmacro!"
_ -> throwStr "invalid defmacro!"
apply_ast ast@(MalList (MalSymbol "macroexpand" : args) _) env = do
case args of
(a1 : []) -> macroexpand a1 env
_ -> throwStr "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
res <- liftIO $ runExceptT $ eval a1 env
case res of
Right val -> return val
Left err -> do
@ -149,7 +149,7 @@ apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
el <- eval_ast (MalList args Nil) env
case el of
(MalList lst _) -> return $ last lst
apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
case args of
(a1 : a2 : a3 : []) -> do
@ -221,7 +221,7 @@ repl_loop env = do
Nothing -> return ()
Just "" -> repl_loop env
Just str -> do
res <- runErrorT $ rep env str
res <- runExceptT $ rep env str
out <- case res of
Left (StringError str) -> return $ "Error: " ++ str
Left (MalValError mv) -> return $ "Error: " ++ (show mv)
@ -242,18 +242,18 @@ main = do
env_set repl_env (MalSymbol "*ARGV*") (MalList [] Nil)
-- core.mal: defined using the language itself
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 "(def! *gensym-counter* (atom 0))"
runErrorT $ rep repl_env "(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))"
runErrorT $ rep repl_env "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))"
runExceptT $ rep repl_env "(def! *host-language* \"haskell\")"
runExceptT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
runExceptT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
runExceptT $ rep repl_env "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))"
runExceptT $ rep repl_env "(def! *gensym-counter* (atom 0))"
runExceptT $ rep repl_env "(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))"
runExceptT $ rep repl_env "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))"
if length args > 0 then do
env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)) Nil)
runErrorT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
runExceptT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
return ()
else do
runErrorT $ rep repl_env "(println (str \"Mal [\" *host-language* \"]\"))"
runExceptT $ rep repl_env "(println (str \"Mal [\" *host-language* \"]\"))"
repl_loop repl_env