kanaka/mal
1
1
Fork 0
mirror of https://github.com/kanaka/mal.git synced 2024-10-26 14:22:25 +03:00
Code Issues Projects Releases Wiki Activity

Haskell: add step7 and 8.

Browse Source
This commit is contained in:
Joel Martin 2014-12-23 23:49:23 -07:00
parent fa9a9758e0
commit 2988d38e84
8 changed files with 497 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
README.md
View File

@ -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

34
haskell/Core.hs
View File

@ -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)]

2
haskell/Env.hs
View File

@ -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)

3
haskell/Makefile
View File

@ -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=%)

41
haskell/Reader.hs
View File

@ -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

6
haskell/Types.hs
View File

@ -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

181
haskell/step7_quote.hs Normal file
View File

@ -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

236
haskell/step8_macros.hs Normal file
View File

@ -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