Haskell: add step7 and 8.

8 files changed, 497 insertions, 9 deletions

diff --git a/README.md b/README.md
index 9dcac17..2d18e92 100644
--- a/README.md
+++ b/README.md
@@ -112,7 +112,8 @@ make
 
 ### Haskell
 
-Install the Haskell compiler (ghc/ghci) and the Haskell platform.
+Install the Haskell compiler (ghc/ghci), the Haskell platform and
+either the editline package (BSD) or the readline package (GPL).
 
 ```
 cd haskell
diff --git a/haskell/Core.hs b/haskell/Core.hs
index 9849ddb..0116d55 100644
--- a/haskell/Core.hs
+++ b/haskell/Core.hs
@@ -20,6 +20,12 @@ run_1 f args = do
          (x:[]) -> return $ f x
          _ -> error $ "function takes a single argument"
 
+run_2 :: (MalVal -> MalVal -> MalVal) -> [MalVal] -> IO MalVal
+run_2 f args = do
+    case args of
+         (x:y:[]) -> return $ f x y
+         _ -> error $ "function takes a two arguments"
+
 
 -- String functions
 
@@ -73,6 +79,29 @@ hash_map args = do
 
 -- Sequence functions
 
+cons x Nil = MalList [x]
+cons x (MalList lst) = MalList $ x:lst
+cons x (MalVector lst) = MalList $ x:lst
+
+concat1 a (MalList lst) = a ++ lst
+concat1 a (MalVector lst) = a ++ lst
+do_concat args = return $ MalList $ foldl concat1 [] args
+
+nth args = do
+    case args of
+        (MalList lst):(MalNumber idx):[] ->
+            if idx < length lst then return $ lst !! idx
+            else error "nth: index out of range"
+        (MalVector lst):(MalNumber idx):[] ->
+            if idx < length lst then return $ lst !! idx
+            else error "nth: index out of range"
+
+first (MalList lst) = if length lst > 0 then lst !! 0 else Nil
+first (MalVector lst) = if length lst > 0 then lst !! 0 else Nil
+
+rest (MalList lst) = MalList $ drop 1 lst
+rest (MalVector lst) = MalList $ drop 1 lst
+
 empty_Q Nil            = MalTrue
 empty_Q (MalList [])   = MalTrue
 empty_Q (MalVector []) = MalTrue
@@ -109,5 +138,10 @@ ns = [
     ("hash-map", _func $ hash_map),
     ("map?",     _func $ run_1 $ _hash_map_Q),
     
+    ("cons", _func $ run_2 $ cons),
+    ("concat", _func $ do_concat),
+    ("nth", _func nth),
+    ("first", _func $ run_1 $ first),
+    ("rest", _func $ run_1 $ rest),
     ("empty?", _func $ run_1 $ empty_Q) ,
     ("count", _func $ run_1 $ count)]
diff --git a/haskell/Env.hs b/haskell/Env.hs
index 9e36a4e..fa85dac 100644
--- a/haskell/Env.hs
+++ b/haskell/Env.hs
@@ -1,5 +1,5 @@
 module Env
-( Env, env_new, null_env, env_bind, env_get, env_set )
+( Env, env_new, null_env, env_bind, env_find, env_get, env_set )
 where
 
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
diff --git a/haskell/Makefile b/haskell/Makefile
index 156a7e7..8e21273 100644
--- a/haskell/Makefile
+++ b/haskell/Makefile
@@ -5,7 +5,8 @@ SOURCES = $(SOURCES_BASE) $(SOURCES_LISP)
 #####################
 
 SRCS = step0_repl.hs step1_read_print.hs step2_eval.hs step3_env.hs \
-       step4_if_fn_do.hs step5_tco.hs step6_file.hs
+       step4_if_fn_do.hs step5_tco.hs step6_file.hs step7_quote.hs \
+       step8_macros.hs
 OTHER_SRCS = Readline.hs Types.hs Reader.hs Printer.hs Env.hs Core.hs
 BINS = $(SRCS:%.hs=%)
 
diff --git a/haskell/Reader.hs b/haskell/Reader.hs
index 8def91c..4f56277 100644
--- a/haskell/Reader.hs
+++ b/haskell/Reader.hs
@@ -3,7 +3,7 @@ module Reader
 where
 
 import Text.ParserCombinators.Parsec (
-    Parser, parse, space, char, digit, letter,
+    Parser, parse, space, char, digit, letter, try,
     (<|>), oneOf, noneOf, many, many1, skipMany, skipMany1, sepEndBy)
 import qualified Data.Map as Map
 import Control.Monad (liftM)
@@ -38,7 +38,6 @@ read_number = liftM (MalNumber . read) $ many1 digit
 read_string :: Parser MalVal
 read_string = do
     char '"'
---    x <- stringChars
     x <- many (escaped <|> noneOf "\\\"")
     char '"'
     return $ MalString x
@@ -87,14 +86,48 @@ read_hash_map = do
     char '}'
     return $ MalHashMap $ Map.fromList $ _pairs x
 
+read_quote :: Parser MalVal
+read_quote = do
+    char '\''
+    x <- read_form
+    return $ MalList [MalSymbol "quote", x]
+
+read_quasiquote :: Parser MalVal
+read_quasiquote = do
+    char '`'
+    x <- read_form
+    return $ MalList [MalSymbol "quasiquote", x]
+
+read_splice_unquote :: Parser MalVal
+read_splice_unquote = do
+    char '~'
+    char '@'
+    x <- read_form
+    return $ MalList [MalSymbol "splice-unquote", x]
+
+read_unquote :: Parser MalVal
+read_unquote = do
+    char '~'
+    x <- read_form
+    return $ MalList [MalSymbol "unquote", x]
+
+
+read_macro :: Parser MalVal
+read_macro = read_quote
+         <|> read_quasiquote
+         <|> try read_splice_unquote <|> read_unquote
 
 read_form :: Parser MalVal
 read_form =  do
     ignored
-    x <- read_atom <|> read_list <|> read_vector <|> read_hash_map
+    x <- read_macro
+     <|> read_list
+     <|> read_vector
+     <|> read_hash_map
+     <|> read_atom
     return $ x
 
 read_str :: String -> IO MalVal
 read_str str = case parse read_form "Mal" str of
-    Left err -> error $ "Blah: " ++ (show err)
+    Left err -> error $ show err
     Right val -> return val
diff --git a/haskell/Types.hs b/haskell/Types.hs
index 9a433c5..25736ec 100644
--- a/haskell/Types.hs
+++ b/haskell/Types.hs
@@ -24,7 +24,8 @@ data MalVal = Nil
             | MalFunc      {fn :: Fn,
                             ast :: MalVal,
                             env :: Env,
-                            params :: MalVal}
+                            params :: MalVal,
+                            macro :: Bool}
 
 _equal_Q Nil Nil = True
 _equal_Q MalFalse MalFalse = True
@@ -82,7 +83,8 @@ catchAny = CE.catch
 
 _func fn = Func $ Fn fn
 _malfunc ast env params fn = MalFunc {fn=(Fn fn), ast=ast,
-                                      env=env, params=params}
+                                      env=env, params=params,
+                                      macro=False}
 
 -- Lists
 
diff --git a/haskell/step7_quote.hs b/haskell/step7_quote.hs
new file mode 100644
index 0000000..bd7640a
--- /dev/null
+++ b/haskell/step7_quote.hs
@@ -0,0 +1,181 @@
+import System.Environment (getArgs)
+import Control.Monad (when, mapM)
+import Control.Monad.Error (throwError)
+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_get, env_set)
+import Core as Core
+
+-- read
+mal_read :: String -> IO 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)]
+         (MalVector (MalList (MalSymbol "splice-unquote" : a01 : []) : rest)) ->
+            MalList [(MalSymbol "concat"), a01, quasiquote (MalVector rest)]
+         (MalList (a0 : rest)) -> MalList [(MalSymbol "cons"),
+                                           quasiquote a0,
+                                           quasiquote (MalList rest)]
+         (MalVector (a0 : rest)) -> MalList [(MalSymbol "cons"),
+                                             quasiquote a0,
+                                             quasiquote (MalVector rest)]
+         _ -> MalList [(MalSymbol "quote"), ast]
+
+
+eval_ast :: MalVal -> Env -> IO MalVal
+eval_ast sym@(MalSymbol _) env = env_get env sym
+eval_ast ast@(MalList lst) env = do
+    new_lst <- mapM (\x -> (eval x env)) lst
+    return $ MalList new_lst
+eval_ast ast@(MalVector lst) env = do
+    new_lst <- mapM (\x -> (eval x env)) lst
+    return $ MalVector new_lst
+eval_ast ast@(MalHashMap lst) env = do
+    new_hm <- DT.mapM (\x -> (eval x env)) lst
+    return $ MalHashMap new_hm
+eval_ast ast env = return ast
+
+let_bind :: Env -> [MalVal] -> IO Env
+let_bind env [] = return env
+let_bind env (b:e:xs) = do
+    evaled <- eval e env
+    x <- env_set env b evaled
+    let_bind env xs
+
+apply_ast :: MalVal -> Env -> IO 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!"
+apply_ast ast@(MalList (MalSymbol "let*" : args)) env = do
+    case args of
+         (MalList a1 : a2 : []) -> do
+            let_env <- env_new $ Just env
+            let_bind let_env a1
+            eval a2 let_env
+         (MalVector a1 : a2 : []) -> do
+            let_env <- env_new $ Just env
+            let_bind let_env a1
+            eval a2 let_env
+         _ -> error $ "invalid let*"
+apply_ast ast@(MalList (MalSymbol "quote" : args)) env = do
+    case args of
+         a1 : [] -> return a1
+         _ -> error $ "invalid quote"
+apply_ast ast@(MalList (MalSymbol "quasiquote" : args)) env = do
+    case args of
+         a1 : [] -> eval (quasiquote a1) env
+         _ -> error $ "invalid quasiquote"
+apply_ast ast@(MalList (MalSymbol "do" : args)) env = do
+    case args of
+         ([]) -> return Nil
+         _  -> do
+            el <- eval_ast (MalList args) env
+            case el of
+                 (MalList el) -> return $ last el
+            
+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
+         _ -> error $ "invalid if"
+apply_ast ast@(MalList (MalSymbol "fn*" : args)) env = do
+    let params = case args of
+                     ((MalList lst) : _)   -> lst
+                     ((MalVector lst) : _) -> lst in
+        case args of
+             (a1 : a2 : []) -> do
+                return $ (_malfunc a2 env a1 (\args -> do
+                    fn_env1 <- env_new $ Just env
+                    fn_env2 <- (env_bind fn_env1 params args)
+                    eval a2 fn_env2))
+             _ -> error $ "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)} : rest)) -> do
+            fn_env1 <- env_new $ Just fn_env
+            fn_env2 <- (env_bind fn_env1 params rest)
+            eval ast fn_env2
+         el ->
+            error $ "invalid apply: " ++ (show el)
+
+eval :: MalVal -> Env -> IO MalVal
+eval ast env = do
+    case ast of
+         (MalList lst) -> apply_ast ast env
+         _             -> eval_ast ast env
+
+
+-- print
+mal_print :: MalVal -> String
+mal_print exp = show exp
+
+-- repl
+
+rep :: Env -> String -> IO 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
+            out <- catchAny (rep env str) $ \e -> do
+                return $ "Error: " ++ (show e)
+            putStrLn out
+            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 [])
+
+    -- 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) \")\")))))"
+
+    if length args > 0 then do
+        env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)))
+        rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")" 
+        return ()
+    else 
+        repl_loop repl_env
diff --git a/haskell/step8_macros.hs b/haskell/step8_macros.hs
new file mode 100644
index 0000000..abc381d
--- /dev/null
+++ b/haskell/step8_macros.hs
@@ -0,0 +1,236 @@
+import System.Environment (getArgs)
+import Control.Monad (when, mapM)
+import Control.Monad.Error (throwError)
+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 -> IO 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)]
+         (MalVector (MalList (MalSymbol "splice-unquote" : a01 : []) : rest)) ->
+            MalList [(MalSymbol "concat"), a01, quasiquote (MalVector rest)]
+         (MalList (a0 : rest)) -> MalList [(MalSymbol "cons"),
+                                           quasiquote a0,
+                                           quasiquote (MalList rest)]
+         (MalVector (a0 : rest)) -> MalList [(MalSymbol "cons"),
+                                             quasiquote a0,
+                                             quasiquote (MalVector rest)]
+         _ -> MalList [(MalSymbol "quote"), ast]
+
+is_macro_call :: MalVal -> Env -> IO Bool
+is_macro_call (MalList (a0@(MalSymbol _) : rest)) env = do
+    e <- 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 -> IO 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 -> IO MalVal
+eval_ast sym@(MalSymbol _) env = env_get env sym
+eval_ast ast@(MalList lst) env = do
+    new_lst <- mapM (\x -> (eval x env)) lst
+    return $ MalList new_lst
+eval_ast ast@(MalVector lst) env = do
+    new_lst <- mapM (\x -> (eval x env)) lst
+    return $ MalVector new_lst
+eval_ast ast@(MalHashMap lst) env = do
+    new_hm <- DT.mapM (\x -> (eval x env)) lst
+    return $ MalHashMap new_hm
+eval_ast ast env = return ast
+
+let_bind :: Env -> [MalVal] -> IO Env
+let_bind env [] = return env
+let_bind env (b:e:xs) = do
+    evaled <- eval e env
+    x <- env_set env b evaled
+    let_bind env xs
+
+apply_ast :: MalVal -> Env -> IO 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!"
+apply_ast ast@(MalList (MalSymbol "let*" : args)) env = do
+    case args of
+         (MalList a1 : a2 : []) -> do
+            let_env <- env_new $ Just env
+            let_bind let_env a1
+            eval a2 let_env
+         (MalVector a1 : a2 : []) -> do
+            let_env <- env_new $ Just env
+            let_bind let_env a1
+            eval a2 let_env
+         _ -> error $ "invalid let*"
+apply_ast ast@(MalList (MalSymbol "quote" : args)) env = do
+    case args of
+         a1 : [] -> return a1
+         _ -> error $ "invalid quote"
+apply_ast ast@(MalList (MalSymbol "quasiquote" : args)) env = do
+    case args of
+         a1 : [] -> eval (quasiquote a1) env
+         _ -> error $ "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} in
+                        env_set env a1 new_func
+                _ -> error $ "defmacro! on non-function"
+         _ -> error $ "invalid defmacro!" 
+apply_ast ast@(MalList (MalSymbol "macroexpand" : args)) env = do
+    case args of
+         (a1 : []) -> macroexpand a1 env
+         _ -> error $ "invalid macroexpand" 
+apply_ast ast@(MalList (MalSymbol "do" : args)) env = do
+    case args of
+         ([]) -> return Nil
+         _  -> do
+            el <- eval_ast (MalList args) env
+            case el of
+                 (MalList el) -> return $ last el
+            
+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
+         _ -> error $ "invalid if"
+apply_ast ast@(MalList (MalSymbol "fn*" : args)) env = do
+    let params = case args of
+                     ((MalList lst) : _)   -> lst
+                     ((MalVector lst) : _) -> lst in
+        case args of
+             (a1 : a2 : []) -> do
+                return $ (_malfunc a2 env a1 (\args -> do
+                    fn_env1 <- env_new $ Just env
+                    fn_env2 <- (env_bind fn_env1 params args)
+                    eval a2 fn_env2))
+             _ -> error $ "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)} : rest)) -> do
+                        fn_env1 <- env_new $ Just fn_env
+                        fn_env2 <- (env_bind fn_env1 params rest)
+                        eval ast fn_env2
+                    el ->
+                        error $ "invalid apply: " ++ (show el)
+            _ -> return ast
+
+eval :: MalVal -> Env -> IO MalVal
+eval ast env = do
+    case ast of
+         (MalList lst) -> apply_ast ast env
+         _             -> eval_ast ast env
+
+
+-- print
+mal_print :: MalVal -> String
+mal_print exp = show exp
+
+-- repl
+
+rep :: Env -> String -> IO 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
+            out <- catchAny (rep env str) $ \e -> do
+                return $ "Error: " ++ (show e)
+            putStrLn out
+            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 [])
+
+    -- 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))))))))"
+
+    if length args > 0 then do
+        env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)))
+        rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")" 
+        return ()
+    else 
+        repl_loop repl_env