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

import System.IO (hFlush, stdout)
import System.Environment (getArgs)
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

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 (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 $ 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
         _  -> 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 <- 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
    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
    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)
        runErrorT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")" 
        return ()
    else do
        runErrorT $ 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 JM	3	import Control.Monad (mapM)
	4	import Control.Monad.Error (runErrorT)
	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
	58	case mac of
	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
c150ec41 JM	89	apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do
	90	case args of
	91	(a1@(MalSymbol _): a2 : []) -> do
	92	evaled <- eval a2 env
5400d4bf JM	93	liftIO $ env_set env a1 evaled
5400d4bf JM	94	_ -> throwStr "invalid def!"
c150ec41 JM	95	apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do
	96	case args of
	97	(a1 : a2 : []) -> do
	98	params <- (_to_list a1)
5400d4bf	99	let_env <- liftIO $ env_new $ Just env
c150ec41 JM	100	let_bind let_env params
c150ec41 JM	101	eval a2 let_env
5400d4bf	102	_ -> throwStr "invalid let*"
c150ec41 JM	103	apply_ast ast@(MalList (MalSymbol "quote" : args) _) env = do
	104	case args of
	105	a1 : [] -> return a1
5400d4bf	106	_ -> throwStr "invalid quote"
c150ec41 JM	107	apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do
	108	case args of
	109	a1 : [] -> eval (quasiquote a1) env
5400d4bf	110	_ -> throwStr "invalid quasiquote"
c150ec41 JM	111
	112	apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = do
	113	case args of
	114	(a1 : a2 : []) -> do
	115	func <- eval a2 env
	116	case func of
	117	MalFunc {fn=f, ast=a, env=e, params=p} -> do
	118	let new_func = MalFunc {fn=f, ast=a, env=e,
	119	params=p, macro=True,
	120	meta=Nil} in
5400d4bf JM	121	liftIO $ env_set env a1 new_func
	122	_ -> throwStr "defmacro! on non-function"
	123	_ -> throwStr "invalid defmacro!"
c150ec41 JM	124	apply_ast ast@(MalList (MalSymbol "macroexpand" : args) _) env = do
	125	case args of
	126	(a1 : []) -> macroexpand a1 env
5400d4bf JM	127	_ -> throwStr "invalid macroexpand"
	128	apply_ast ast@(MalList (MalSymbol "try*" : args) _) env = do
	129	case args of
	130	(a1 : []) -> eval a1 env
	131	(a1 : (MalList ((MalSymbol "catch*") : a21 : a22 : []) _) : []) -> do
	132	res <- liftIO $ runErrorT $ eval a1 env
	133	case res of
	134	Right val -> return val
	135	Left err -> do
	136	exc <- case err of
	137	(StringError str) -> return $ MalString str
	138	(MalValError mv) -> return $ mv
	139	try_env <- liftIO $ env_new $ Just env
	140	liftIO $ env_set try_env a21 exc
	141	eval a22 try_env
	142	_ -> throwStr "invalid try*"
c150ec41 JM	143	apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
	144	case args of
	145	([]) -> return Nil
	146	_ -> do
	147	el <- eval_ast (MalList args Nil) env
	148	case el of
	149	(MalList lst _) -> return $ last lst
	150
	151	apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
	152	case args of
	153	(a1 : a2 : a3 : []) -> do
	154	cond <- eval a1 env
	155	if cond == MalFalse \|\| cond == Nil
	156	then eval a3 env
	157	else eval a2 env
	158	(a1 : a2 : []) -> do
	159	cond <- eval a1 env
	160	if cond == MalFalse \|\| cond == Nil
	161	then return Nil
	162	else eval a2 env
5400d4bf	163	_ -> throwStr "invalid if"
c150ec41 JM	164	apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do
	165	case args of
	166	(a1 : a2 : []) -> do
	167	params <- (_to_list a1)
	168	return $ (_malfunc a2 env (MalList params Nil)
	169	(\args -> do
5400d4bf JM	170	fn_env1 <- liftIO $ env_new $ Just env
5400d4bf JM	171	fn_env2 <- liftIO $ env_bind fn_env1 params args
c150ec41	172	eval a2 fn_env2))
5400d4bf	173	_ -> throwStr "invalid fn*"
c150ec41 JM	174	apply_ast ast@(MalList _ _) env = do
	175	mc <- is_macro_call ast env
	176	if mc then do
	177	new_ast <- macroexpand ast env
	178	eval new_ast env
	179	else
	180	case ast of
	181	MalList _ _ -> do
	182	el <- eval_ast ast env
	183	case el of
	184	(MalList ((Func (Fn f) _) : rest) _) ->
	185	f $ rest
	186	(MalList ((MalFunc {ast=ast,
	187	env=fn_env,
	188	params=(MalList params Nil)} : rest)) _) -> do
5400d4bf JM	189	fn_env1 <- liftIO $ env_new $ Just fn_env
5400d4bf JM	190	fn_env2 <- liftIO $ env_bind fn_env1 params rest
c150ec41 JM	191	eval ast fn_env2
c150ec41 JM	192	el ->
5400d4bf	193	throwStr $ "invalid apply: " ++ (show el)
c150ec41 JM	194	_ -> return ast
c150ec41 JM	195
5400d4bf	196	eval :: MalVal -> Env -> IOThrows MalVal
c150ec41 JM	197	eval ast env = do
	198	case ast of
	199	(MalList _ _) -> apply_ast ast env
	200	_ -> eval_ast ast env
	201
	202
	203	-- print
	204	mal_print :: MalVal -> String
	205	mal_print exp = show exp
	206
	207	-- repl
	208
5400d4bf	209	rep :: Env -> String -> IOThrows String
c150ec41 JM	210	rep env line = do
	211	ast <- mal_read line
	212	exp <- eval ast env
	213	return $ mal_print exp
	214
	215	repl_loop :: Env -> IO ()
	216	repl_loop env = do
	217	line <- readline "user> "
	218	case line of
	219	Nothing -> return ()
	220	Just "" -> repl_loop env
	221	Just str -> do
5400d4bf JM	222	res <- runErrorT $ rep env str
	223	out <- case res of
	224	Left (StringError str) -> return $ "Error: " ++ str
	225	Left (MalValError mv) -> return $ "Error: " ++ (show mv)
	226	Right val -> return val
c150ec41	227	putStrLn out
5400d4bf	228	hFlush stdout
c150ec41 JM	229	repl_loop env
	230
	231	main = do
	232	args <- getArgs
	233	load_history
	234
	235	repl_env <- env_new Nothing
	236
	237	-- core.hs: defined using Haskell
	238	(mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns)
	239	env_set repl_env (MalSymbol "eval") (_func (\[ast] -> eval ast repl_env))
	240	env_set repl_env (MalSymbol "ARGV") (MalList [] Nil)
	241
	242	-- core.mal: defined using the language itself
5400d4bf JM	243	runErrorT $ rep repl_env "(def! host-language \"haskell\")"
	244	runErrorT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
	245	runErrorT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
	246	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)))))))"
	247	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))))))))"
c150ec41 JM	248
	249	if length args > 0 then do
	250	env_set repl_env (MalSymbol "ARGV") (MalList (map MalString (drop 1 args)) Nil)
5400d4bf	251	runErrorT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
c150ec41 JM	252	return ()
c150ec41 JM	253	else do
5400d4bf	254	runErrorT $ rep repl_env "(println (str \"Mal [\" host-language \"]\"))"
c150ec41	255	repl_loop repl_env