[jackhill/mal.git] / haskell / stepA_mal.hs

import System.IO (hFlush, stdout)
import System.Environment (getArgs)
import Control.Monad (mapM)
import Control.Monad.Except (runExceptT)
import Control.Monad.Trans (liftIO)
import qualified Data.Map as Map
import qualified Data.Traversable as DT

import Readline (readline, load_history)
import Types
import Reader (read_str)
import Printer (_pr_str)
import Env (Env, env_new, env_bind, env_find, env_get, env_set)
import Core as Core

-- read
mal_read :: String -> IOThrows MalVal
mal_read str = read_str str

-- eval
is_pair (MalList x _:xs) = True
is_pair (MalVector x _:xs) = True
is_pair _ = False

quasiquote :: MalVal -> MalVal
quasiquote ast =
    case ast of
         (MalList (MalSymbol "unquote" : a1 : []) _) -> a1
         (MalList (MalList (MalSymbol "splice-unquote" : a01 : []) _ : rest) _) ->
            MalList [(MalSymbol "concat"), a01, quasiquote (MalList rest Nil)] Nil
         (MalVector (MalList (MalSymbol "splice-unquote" : a01 : []) _ : rest) _) ->
            MalList [(MalSymbol "concat"), a01, quasiquote (MalVector rest Nil)] Nil
         (MalList (a0 : rest) _) -> MalList [(MalSymbol "cons"),
                                             quasiquote a0,
                                             quasiquote (MalList rest Nil)] Nil
         (MalVector (a0 : rest) _) -> MalList [(MalSymbol "cons"),
                                               quasiquote a0,
                                               quasiquote (MalVector rest Nil)] Nil
         _ -> MalList [(MalSymbol "quote"), ast] Nil

is_macro_call :: MalVal -> Env -> IOThrows Bool
is_macro_call (MalList (a0@(MalSymbol _) : rest) _) env = do
    e <- liftIO $ env_find env a0
    case e of
         Just e -> do
            f <- env_get e a0
            case f of
                 MalFunc {macro=True} -> return True
                 _                    -> return False
         Nothing -> return False
is_macro_call _ _ = return False

macroexpand :: MalVal -> Env -> IOThrows MalVal
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
             MalFunc {fn=(Fn f)} -> do
                new_ast <- f args
                macroexpand new_ast env
             _ ->
                return ast
    else
        return ast
macroexpand ast _ = return ast

eval_ast :: MalVal -> Env -> IOThrows MalVal
eval_ast sym@(MalSymbol _) env = env_get env sym
eval_ast ast@(MalList lst m) env = do
    new_lst <- mapM (\x -> (eval x env)) lst
    return $ MalList new_lst m
eval_ast ast@(MalVector lst m) env = do
    new_lst <- mapM (\x -> (eval x env)) lst
    return $ MalVector new_lst m
eval_ast ast@(MalHashMap lst m) env = do
    new_hm <- DT.mapM (\x -> (eval x env)) lst
    return $ MalHashMap new_hm m
eval_ast ast env = return ast

let_bind :: Env -> [MalVal] -> IOThrows Env
let_bind env [] = return env
let_bind env (b:e:xs) = do
    evaled <- eval e env
    x <- liftIO $ env_set env b evaled
    let_bind env xs

apply_ast :: MalVal -> Env -> IOThrows MalVal
apply_ast ast@(MalList [] _) env = do
    return ast
apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do
    case args of
         (a1@(MalSymbol _): a2 : []) -> do
            evaled <- eval a2 env
            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 <- liftIO $ env_new $ Just env
            let_bind let_env params
            eval a2 let_env
         _ -> throwStr "invalid let*"
apply_ast ast@(MalList (MalSymbol "quote" : args) _) env = do
    case args of
         a1 : [] -> return a1
         _ -> throwStr "invalid quote"
apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do
    case args of
         a1 : [] -> eval (quasiquote a1) env
         _ -> throwStr "invalid quasiquote"

apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = do
    case args of
         (a1 : a2 : []) -> do
            func <- eval a2 env
            case func of
                MalFunc {fn=f, ast=a, env=e, params=p} -> do
                    let new_func = MalFunc {fn=f, ast=a, env=e,
                                            params=p, macro=True,
                                            meta=Nil} in
                        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
         _ -> 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 $ runExceptT $ 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
         _  -> 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
            cond <- eval a1 env
            if cond == MalFalse || cond == Nil
                then eval a3 env
                else eval a2 env
         (a1 : a2 : []) -> do
            cond <- eval a1 env
            if cond == MalFalse || cond == Nil
                then return Nil
                else eval a2 env
         _ -> 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 <- liftIO $ env_new $ Just env
                        fn_env2 <- liftIO $ env_bind fn_env1 params args
                        eval a2 fn_env2))
         _ -> throwStr "invalid fn*"
apply_ast ast@(MalList _ _) env = do
    mc <- is_macro_call ast env
    if mc then do
        new_ast <- macroexpand ast env
        eval new_ast env
    else
        case ast of
            MalList _ _ -> 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 <- liftIO $ env_new $ Just fn_env
                        fn_env2 <- liftIO $ env_bind fn_env1 params rest
                        eval ast fn_env2
                    el ->
                        throwStr $ "invalid apply: " ++ (show el)
            _ -> return ast

eval :: MalVal -> Env -> IOThrows MalVal
eval ast env = do
    case ast of
         (MalList _ _) -> apply_ast ast env
         _             -> eval_ast ast env


-- print
mal_print :: MalVal -> String
mal_print exp = show exp

-- repl

rep :: Env -> String -> IOThrows String
rep env line = do
    ast <- mal_read line
    exp <- eval ast env
    return $ mal_print exp

repl_loop :: Env -> IO ()
repl_loop env = do
    line <- readline "user> "
    case line of
        Nothing -> return ()
        Just "" -> repl_loop env
        Just str -> do
            res <- runExceptT $ 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
    args <- getArgs
    load_history

    repl_env <- env_new Nothing

    -- core.hs: defined using Haskell
    (mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns)
    env_set repl_env (MalSymbol "eval") (_func (\[ast] -> eval ast repl_env))
    env_set repl_env (MalSymbol "*ARGV*") (MalList [] Nil)

    -- core.mal: defined using the language itself
    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! inc (fn* [x] (+ x 1)))"
    runExceptT $ rep repl_env "(def! gensym (let* [counter (atom 0)] (fn* [] (symbol (str \"G__\" (swap! counter inc))))))"
    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)
        runExceptT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
        return ()
    else do
        runExceptT $ rep repl_env "(println (str \"Mal [\" *host-language* \"]\"))"
        repl_loop repl_env
Commit	Line	Data
5400d4bf	1	import System.IO (hFlush, stdout)
c150ec41	2	import System.Environment (getArgs)
5400d4bf	3	import Control.Monad (mapM)
53db2d63	4	import Control.Monad.Except (runExceptT)
5400d4bf	5	import Control.Monad.Trans (liftIO)
c150ec41 JM	6	import qualified Data.Map as Map
	7	import qualified Data.Traversable as DT
	8
	9	import Readline (readline, load_history)
	10	import Types
	11	import Reader (read_str)
	12	import Printer (_pr_str)
	13	import Env (Env, env_new, env_bind, env_find, env_get, env_set)
	14	import Core as Core
	15
	16	-- read
5400d4bf	17	mal_read :: String -> IOThrows MalVal
c150ec41 JM	18	mal_read str = read_str str
	19
	20	-- eval
	21	is_pair (MalList x _:xs) = True
	22	is_pair (MalVector x _:xs) = True
	23	is_pair _ = False
	24
	25	quasiquote :: MalVal -> MalVal
	26	quasiquote ast =
	27	case ast of
	28	(MalList (MalSymbol "unquote" : a1 : []) _) -> a1
	29	(MalList (MalList (MalSymbol "splice-unquote" : a01 : []) _ : rest) _) ->
	30	MalList [(MalSymbol "concat"), a01, quasiquote (MalList rest Nil)] Nil
	31	(MalVector (MalList (MalSymbol "splice-unquote" : a01 : []) _ : rest) _) ->
	32	MalList [(MalSymbol "concat"), a01, quasiquote (MalVector rest Nil)] Nil
	33	(MalList (a0 : rest) _) -> MalList [(MalSymbol "cons"),
	34	quasiquote a0,
	35	quasiquote (MalList rest Nil)] Nil
	36	(MalVector (a0 : rest) _) -> MalList [(MalSymbol "cons"),
	37	quasiquote a0,
	38	quasiquote (MalVector rest Nil)] Nil
	39	_ -> MalList [(MalSymbol "quote"), ast] Nil
	40
5400d4bf	41	is_macro_call :: MalVal -> Env -> IOThrows Bool
c150ec41	42	is_macro_call (MalList (a0@(MalSymbol _) : rest) _) env = do
5400d4bf	43	e <- liftIO $ env_find env a0
c150ec41 JM	44	case e of
	45	Just e -> do
	46	f <- env_get e a0
	47	case f of
	48	MalFunc {macro=True} -> return True
	49	_ -> return False
	50	Nothing -> return False
	51	is_macro_call _ _ = return False
	52
5400d4bf	53	macroexpand :: MalVal -> Env -> IOThrows MalVal
c150ec41 JM	54	macroexpand ast@(MalList (a0 : args) _) env = do
	55	mc <- is_macro_call ast env
	56	if mc then do
	57	mac <- env_get env a0
53db2d63	58	case mac of
c150ec41 JM	59	MalFunc {fn=(Fn f)} -> do
	60	new_ast <- f args
	61	macroexpand new_ast env
	62	_ ->
	63	return ast
	64	else
	65	return ast
	66	macroexpand ast _ = return ast
	67
5400d4bf	68	eval_ast :: MalVal -> Env -> IOThrows MalVal
c150ec41 JM	69	eval_ast sym@(MalSymbol _) env = env_get env sym
	70	eval_ast ast@(MalList lst m) env = do
	71	new_lst <- mapM (\x -> (eval x env)) lst
	72	return $ MalList new_lst m
	73	eval_ast ast@(MalVector lst m) env = do
	74	new_lst <- mapM (\x -> (eval x env)) lst
	75	return $ MalVector new_lst m
	76	eval_ast ast@(MalHashMap lst m) env = do
	77	new_hm <- DT.mapM (\x -> (eval x env)) lst
	78	return $ MalHashMap new_hm m
	79	eval_ast ast env = return ast
	80
5400d4bf	81	let_bind :: Env -> [MalVal] -> IOThrows Env
c150ec41 JM	82	let_bind env [] = return env
	83	let_bind env (b:e:xs) = do
	84	evaled <- eval e env
5400d4bf	85	x <- liftIO $ env_set env b evaled
c150ec41 JM	86	let_bind env xs
c150ec41 JM	87
5400d4bf	88	apply_ast :: MalVal -> Env -> IOThrows MalVal
cffab551 DM	89	apply_ast ast@(MalList [] _) env = do
cffab551 DM	90	return ast
c150ec41 JM	91	apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do
	92	case args of
	93	(a1@(MalSymbol _): a2 : []) -> do
	94	evaled <- eval a2 env
5400d4bf JM	95	liftIO $ env_set env a1 evaled
5400d4bf JM	96	_ -> throwStr "invalid def!"
c150ec41 JM	97	apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do
	98	case args of
	99	(a1 : a2 : []) -> do
	100	params <- (_to_list a1)
5400d4bf	101	let_env <- liftIO $ env_new $ Just env
c150ec41 JM	102	let_bind let_env params
c150ec41 JM	103	eval a2 let_env
5400d4bf	104	_ -> throwStr "invalid let*"
c150ec41 JM	105	apply_ast ast@(MalList (MalSymbol "quote" : args) _) env = do
	106	case args of
	107	a1 : [] -> return a1
5400d4bf	108	_ -> throwStr "invalid quote"
c150ec41 JM	109	apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do
	110	case args of
	111	a1 : [] -> eval (quasiquote a1) env
5400d4bf	112	_ -> throwStr "invalid quasiquote"
c150ec41 JM	113
	114	apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = do
	115	case args of
	116	(a1 : a2 : []) -> do
	117	func <- eval a2 env
	118	case func of
	119	MalFunc {fn=f, ast=a, env=e, params=p} -> do
	120	let new_func = MalFunc {fn=f, ast=a, env=e,
	121	params=p, macro=True,
	122	meta=Nil} in
5400d4bf JM	123	liftIO $ env_set env a1 new_func
5400d4bf JM	124	_ -> throwStr "defmacro! on non-function"
53db2d63	125	_ -> throwStr "invalid defmacro!"
c150ec41 JM	126	apply_ast ast@(MalList (MalSymbol "macroexpand" : args) _) env = do
	127	case args of
	128	(a1 : []) -> macroexpand a1 env
53db2d63	129	_ -> throwStr "invalid macroexpand"
5400d4bf JM	130	apply_ast ast@(MalList (MalSymbol "try*" : args) _) env = do
	131	case args of
	132	(a1 : []) -> eval a1 env
	133	(a1 : (MalList ((MalSymbol "catch*") : a21 : a22 : []) _) : []) -> do
53db2d63	134	res <- liftIO $ runExceptT $ eval a1 env
5400d4bf JM	135	case res of
	136	Right val -> return val
	137	Left err -> do
	138	exc <- case err of
	139	(StringError str) -> return $ MalString str
	140	(MalValError mv) -> return $ mv
	141	try_env <- liftIO $ env_new $ Just env
	142	liftIO $ env_set try_env a21 exc
	143	eval a22 try_env
	144	_ -> throwStr "invalid try*"
c150ec41 JM	145	apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
	146	case args of
	147	([]) -> return Nil
	148	_ -> do
	149	el <- eval_ast (MalList args Nil) env
	150	case el of
	151	(MalList lst _) -> return $ last lst
53db2d63	152
c150ec41 JM	153	apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
	154	case args of
	155	(a1 : a2 : a3 : []) -> do
	156	cond <- eval a1 env
	157	if cond == MalFalse \|\| cond == Nil
	158	then eval a3 env
	159	else eval a2 env
	160	(a1 : a2 : []) -> do
	161	cond <- eval a1 env
	162	if cond == MalFalse \|\| cond == Nil
	163	then return Nil
	164	else eval a2 env
5400d4bf	165	_ -> throwStr "invalid if"
c150ec41 JM	166	apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do
	167	case args of
	168	(a1 : a2 : []) -> do
	169	params <- (_to_list a1)
	170	return $ (_malfunc a2 env (MalList params Nil)
	171	(\args -> do
5400d4bf JM	172	fn_env1 <- liftIO $ env_new $ Just env
5400d4bf JM	173	fn_env2 <- liftIO $ env_bind fn_env1 params args
c150ec41	174	eval a2 fn_env2))
5400d4bf	175	_ -> throwStr "invalid fn*"
c150ec41 JM	176	apply_ast ast@(MalList _ _) env = do
	177	mc <- is_macro_call ast env
	178	if mc then do
	179	new_ast <- macroexpand ast env
	180	eval new_ast env
	181	else
	182	case ast of
	183	MalList _ _ -> do
	184	el <- eval_ast ast env
	185	case el of
	186	(MalList ((Func (Fn f) _) : rest) _) ->
	187	f $ rest
	188	(MalList ((MalFunc {ast=ast,
	189	env=fn_env,
	190	params=(MalList params Nil)} : rest)) _) -> do
5400d4bf JM	191	fn_env1 <- liftIO $ env_new $ Just fn_env
5400d4bf JM	192	fn_env2 <- liftIO $ env_bind fn_env1 params rest
c150ec41 JM	193	eval ast fn_env2
c150ec41 JM	194	el ->
5400d4bf	195	throwStr $ "invalid apply: " ++ (show el)
c150ec41 JM	196	_ -> return ast
c150ec41 JM	197
5400d4bf	198	eval :: MalVal -> Env -> IOThrows MalVal
c150ec41 JM	199	eval ast env = do
	200	case ast of
	201	(MalList _ _) -> apply_ast ast env
	202	_ -> eval_ast ast env
	203
	204
	205	-- print
	206	mal_print :: MalVal -> String
	207	mal_print exp = show exp
	208
	209	-- repl
	210
5400d4bf	211	rep :: Env -> String -> IOThrows String
c150ec41 JM	212	rep env line = do
	213	ast <- mal_read line
	214	exp <- eval ast env
	215	return $ mal_print exp
	216
	217	repl_loop :: Env -> IO ()
	218	repl_loop env = do
	219	line <- readline "user> "
	220	case line of
	221	Nothing -> return ()
	222	Just "" -> repl_loop env
	223	Just str -> do
53db2d63	224	res <- runExceptT $ rep env str
5400d4bf JM	225	out <- case res of
	226	Left (StringError str) -> return $ "Error: " ++ str
	227	Left (MalValError mv) -> return $ "Error: " ++ (show mv)
	228	Right val -> return val
c150ec41	229	putStrLn out
5400d4bf	230	hFlush stdout
c150ec41 JM	231	repl_loop env
	232
	233	main = do
	234	args <- getArgs
	235	load_history
	236
	237	repl_env <- env_new Nothing
	238
	239	-- core.hs: defined using Haskell
	240	(mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns)
	241	env_set repl_env (MalSymbol "eval") (_func (\[ast] -> eval ast repl_env))
	242	env_set repl_env (MalSymbol "ARGV") (MalList [] Nil)
	243
	244	-- core.mal: defined using the language itself
53db2d63 P	245	runExceptT $ rep repl_env "(def! host-language \"haskell\")"
	246	runExceptT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
	247	runExceptT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
	248	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)))))))"
14ab099c NB	249	runExceptT $ rep repl_env "(def! inc (fn* [x] (+ x 1)))"
14ab099c NB	250	runExceptT $ rep repl_env "(def! gensym (let* [counter (atom 0)] (fn* [] (symbol (str \"G__\" (swap! counter inc))))))"
53db2d63	251	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)))))))))"
c150ec41 JM	252
	253	if length args > 0 then do
	254	env_set repl_env (MalSymbol "ARGV") (MalList (map MalString (drop 1 args)) Nil)
53db2d63	255	runExceptT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
c150ec41 JM	256	return ()
c150ec41 JM	257	else do
53db2d63	258	runExceptT $ rep repl_env "(println (str \"Mal [\" host-language \"]\"))"
c150ec41	259	repl_loop repl_env