From b76aa73bc76a28d7c6bb3c5a43acc9afd9ec42c8 Mon Sep 17 00:00:00 2001 From: Joel Martin Date: Tue, 23 Dec 2014 20:35:48 -0700 Subject: Haskell: steps 0-3 --- haskell/Env.hs | 67 ++++++++++++++++++++++++++ haskell/Makefile | 29 +++++++++++ haskell/Printer.hs | 36 ++++++++++++++ haskell/Reader.hs | 98 +++++++++++++++++++++++++++++++++++++ haskell/Types.hs | 49 +++++++++++++++++++ haskell/step0_repl.hs | 28 +++++++++++ haskell/step1_read_print.hs | 42 ++++++++++++++++ haskell/step2_eval.hs | 93 +++++++++++++++++++++++++++++++++++ haskell/step3_env.hs | 115 ++++++++++++++++++++++++++++++++++++++++++++ 9 files changed, 557 insertions(+) create mode 100644 haskell/Env.hs create mode 100644 haskell/Makefile create mode 100644 haskell/Printer.hs create mode 100644 haskell/Reader.hs create mode 100644 haskell/Types.hs create mode 100644 haskell/step0_repl.hs create mode 100644 haskell/step1_read_print.hs create mode 100644 haskell/step2_eval.hs create mode 100644 haskell/step3_env.hs (limited to 'haskell') diff --git a/haskell/Env.hs b/haskell/Env.hs new file mode 100644 index 0000000..535f270 --- /dev/null +++ b/haskell/Env.hs @@ -0,0 +1,67 @@ +module Env +( Env, env_new, null_env, env_get, env_set ) +where + +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Control.Monad.Trans (liftIO) +import Data.List (elemIndex) +import qualified Data.Map as Map + +import Types +import Printer + +data EnvData = EnvPair (Maybe Env, (Map.Map String MalVal)) + +type Env = IORef EnvData + +env_new :: Maybe Env -> IO Env +env_new outer = newIORef $ EnvPair (outer, (Map.fromList [])) + +null_env = env_new Nothing + +env_bind :: Env -> [MalVal] -> [MalVal] -> IO Env +env_bind env binds exprs = do + case (elemIndex (MalSymbol "&") binds) of + Just idx -> return env + Nothing -> return env + +{- +isBound :: Env -> MalVal -> IO Bool +--isBound envRef var = readIORef envRef >>= return . maybe False (const True) . lookup var +isBound envRef (MalSymbol key) = do + e <- readIORef envRef + case e of + EnvPair (o,m) -> case Map.lookup key m of + Nothing -> return False + Just _ -> return True +-} + +env_find :: Env -> MalVal -> IO (Maybe Env) +env_find envRef sym@(MalSymbol key) = do + e <- readIORef envRef + case e of + EnvPair (o, m) -> case Map.lookup key m of + Nothing -> case o of + Nothing -> return Nothing + Just o -> env_find o sym + Just val -> return $ Just envRef + +env_get :: Env -> MalVal -> IO MalVal +env_get envRef sym@(MalSymbol key) = do + e1 <- liftIO $ env_find envRef sym + case e1 of + Nothing -> error $ "'" ++ key ++ "' not found" + Just eRef -> do + e2 <- liftIO $ readIORef eRef + case e2 of + EnvPair (o,m) -> case Map.lookup key m of + Nothing -> error $ "env_get error" + Just val -> return val + + +env_set :: Env -> MalVal -> MalVal -> IO MalVal +env_set envRef (MalSymbol key) val = do + e <- readIORef envRef + case e of + EnvPair (o,m) -> writeIORef envRef $ EnvPair (o, (Map.insert key val m)) + return val diff --git a/haskell/Makefile b/haskell/Makefile new file mode 100644 index 0000000..d43db16 --- /dev/null +++ b/haskell/Makefile @@ -0,0 +1,29 @@ +SOURCES_BASE = +SOURCES_LISP = step0_repl.hs +SOURCES = $(SOURCES_BASE) $(SOURCES_LISP) + +##################### + +SRCS = step0_repl.hs step1_read_print.hs step2_eval.hs step3_env.hs +OTHER_SRCS = Types.hs Reader.hs Printer.hs Env.hs +BINS = $(SRCS:%.hs=%) + +##################### + +all: $(BINS) mal + +mal: $(word $(words $(BINS)),$(BINS)) + cp $< $@ + +$(BINS): %: %.hs $(OTHER_SRCS) + ghc --make $< -o $@ + +clean: + rm -f $(BINS) mal *.hi *.o + +.PHONY: stats stats-lisp tests $(TESTS) + +stats: $(SOURCES) + @wc $^ +stats-lisp: $(SOURCES_LISP) + @wc $^ diff --git a/haskell/Printer.hs b/haskell/Printer.hs new file mode 100644 index 0000000..94bc5ed --- /dev/null +++ b/haskell/Printer.hs @@ -0,0 +1,36 @@ +module Printer +( _pr_str ) +where + +import qualified Data.Map as Map + +import Types + +_pr_list :: [MalVal] -> String +_pr_list = unwords . map _pr_str + +_flatTuples ((a,b):xs) = MalString a : b : _flatTuples xs +_flatTuples _ = [] + +unescape chr = case chr of + '\n' -> "\\n" + '\\' -> "\\\\" + '"' -> "\\\"" + c -> [c] + +_pr_str :: MalVal -> String +_pr_str (MalString ('\x029e':str)) = ":" ++ str +_pr_str (MalString str) = "\"" ++ concatMap unescape str ++ "\"" +_pr_str (MalSymbol name) = name +_pr_str (MalKeyword name) = ":" ++ name +_pr_str (MalNumber num) = show num +_pr_str (MalTrue) = "true" +_pr_str (MalFalse) = "false" +_pr_str (Nil) = "nil" +_pr_str (MalList items) = "(" ++ _pr_list items ++ ")" +_pr_str (MalVector items) = "[" ++ _pr_list items ++ "]" +_pr_str (MalHashMap m) = "{" ++ _pr_list (_flatTuples $ Map.assocs m) ++ "}" +_pr_str (MalFunc f) = "#" + +instance Show MalVal where show = _pr_str + diff --git a/haskell/Reader.hs b/haskell/Reader.hs new file mode 100644 index 0000000..04381f4 --- /dev/null +++ b/haskell/Reader.hs @@ -0,0 +1,98 @@ +module Reader +( read_str ) +where + +import Text.ParserCombinators.Parsec ( + Parser, parse, space, char, digit, letter, + (<|>), oneOf, noneOf, many, many1, skipMany1, sepEndBy) +import qualified Data.Map as Map +import Control.Monad (liftM) + +import Types + +spaces :: Parser () +spaces = skipMany1 (oneOf ", ") + +symbol :: Parser Char +symbol = oneOf "!#$%&|*+-/:<=>?@^_~" + +escaped :: Parser Char +escaped = do + char '\\' + x <- oneOf "\\\"n" + case x of + 'n' -> return '\n' + _ -> return x + +read_number :: Parser MalVal +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 + +read_symbol :: Parser MalVal +read_symbol = do + first <- letter <|> symbol + rest <- many (letter <|> digit <|> symbol) + let str = first:rest + return $ case str of + "true" -> MalTrue + "false" -> MalFalse + "nil" -> Nil + _ -> MalSymbol str + +read_keyword :: Parser MalVal +read_keyword = do + char ':' + x <- many (letter <|> digit <|> symbol) + return $ MalKeyword x + +read_atom :: Parser MalVal +read_atom = read_number + <|> read_string + <|> read_keyword + <|> read_symbol + +read_list :: Parser MalVal +read_list = do + char '(' + x <- sepEndBy read_form spaces + char ')' + return $ MalList x + +read_vector :: Parser MalVal +read_vector = do + char '[' + x <- sepEndBy read_form spaces + char ']' + return $ MalVector x + +-- TODO: propagate error properly +_pairs [x] = error "Odd number of element for hashmap" +_pairs [] = [] +_pairs (MalString x:y:xs) = (x,y):_pairs xs +_pairs (MalKeyword x:y:xs) = ("\x029e" ++ x,y):_pairs xs + +read_hash_map :: Parser MalVal +read_hash_map = do + char '{' + x <- sepEndBy read_form spaces + char '}' + return $ MalHashMap $ Map.fromList $ _pairs x + + +read_form :: Parser MalVal +read_form = do + many spaces + x <- read_atom <|> read_list <|> read_vector <|> read_hash_map + return $ x + +read_str :: String -> IO MalVal +read_str str = case parse read_form "Mal" str of + Left err -> error $ "Blah: " ++ (show err) + Right val -> return val diff --git a/haskell/Types.hs b/haskell/Types.hs new file mode 100644 index 0000000..bec26be --- /dev/null +++ b/haskell/Types.hs @@ -0,0 +1,49 @@ +module Types +--( MalVal (Nil,MalFalse,MalTrue,MalNumber,MalString,MalSymbol,MalKeyword,MalList,MalVector,MalFunc), _obj_type ) +(MalVal (..), FuncT (..), _malfunc, catchAny) +where + +import qualified Data.Map as Map +import Control.Exception (SomeException, catch) + +-- Based Mal types -- +newtype FuncT = FuncT (MalVal -> MalVal) +data MalVal = Nil + | MalFalse + | MalTrue + | MalNumber Int + | MalString String + | MalSymbol String + | MalKeyword String + | MalList [MalVal] + | MalVector [MalVal] + | MalHashMap (Map.Map String MalVal) + | MalFunc FuncT + deriving (Eq) + +instance Eq FuncT where + x == y = False + +_malfunc f = MalFunc $ FuncT f + + +-- Error definitions -- +catchAny :: IO a -> (SomeException -> IO a) -> IO a +catchAny = catch + + +---------------------------------------------------------- + +-- General type functions -- + +_obj_type :: MalVal -> String +_obj_type (Nil) = "nil" +_obj_type (MalFalse) = "false" +_obj_type (MalTrue) = "true" +_obj_type (MalNumber _) = "number" +_obj_type (MalString _) = "string" +_obj_type (MalSymbol _) = "symbol" +_obj_type (MalList _) = "list" +_obj_type (MalVector _) = "vector" +_obj_type (MalHashMap _) = "hashmap" +_obj_type (MalFunc _) = "malfunc" diff --git a/haskell/step0_repl.hs b/haskell/step0_repl.hs new file mode 100644 index 0000000..d944263 --- /dev/null +++ b/haskell/step0_repl.hs @@ -0,0 +1,28 @@ +import System.IO (hGetLine, hFlush, hIsEOF, stdin, stdout) +import Control.Monad + +-- read +mal_read str = str + +-- eval +eval ast env = ast + +-- print +mal_print exp = exp + +-- repl +rep line = mal_print $ eval (mal_read line) "" + +repl_loop = do + putStr "user> " + hFlush stdout + ineof <- hIsEOF stdin + when (not ineof) $ do + line <- hGetLine stdin + if null line + then repl_loop + else do + putStrLn $ rep line + repl_loop + +main = repl_loop diff --git a/haskell/step1_read_print.hs b/haskell/step1_read_print.hs new file mode 100644 index 0000000..56f2024 --- /dev/null +++ b/haskell/step1_read_print.hs @@ -0,0 +1,42 @@ +import System.IO (hGetLine, hFlush, hIsEOF, stdin, stdout) +import Control.Monad (when) +import Control.Monad.Error (throwError) + +import Types +import Reader (read_str) +import Printer (_pr_str) + +-- read +mal_read :: String -> IO MalVal +mal_read str = read_str str + +-- eval +eval :: MalVal -> String -> MalVal +eval ast env = ast + +-- print +mal_print :: MalVal -> String +mal_print exp = show exp + +-- repl +rep :: String -> IO String +rep line = do + ast <- mal_read line + return $ mal_print (eval ast "") + +repl_loop :: IO () +repl_loop = do + putStr "user> " + hFlush stdout + ineof <- hIsEOF stdin + when (not ineof) $ do + line <- hGetLine stdin + if null line + then repl_loop + else do + out <- catchAny (rep line) $ \e -> do + return $ "Error: " ++ (show e) + putStrLn out + repl_loop + +main = repl_loop diff --git a/haskell/step2_eval.hs b/haskell/step2_eval.hs new file mode 100644 index 0000000..0a95fcc --- /dev/null +++ b/haskell/step2_eval.hs @@ -0,0 +1,93 @@ +import System.IO (hGetLine, hFlush, hIsEOF, stdin, stdout) +import Control.Monad (when, mapM) +import Control.Monad.Error (throwError) +import qualified Data.Map as Map +import qualified Data.Traversable as DT + +import Types +import Reader (read_str) +import Printer (_pr_str) + +-- read +mal_read :: String -> IO MalVal +mal_read str = read_str str + +-- eval +eval_ast :: MalVal -> (Map.Map String MalVal) -> IO MalVal +eval_ast (MalSymbol sym) env = do + case Map.lookup sym env of + Nothing -> error $ "'" ++ sym ++ "' not found" + Just v -> return v +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 + +apply_ast :: MalVal -> (Map.Map String MalVal) -> IO MalVal +apply_ast ast@(MalList _) env = do + el <- eval_ast ast env + case el of + (MalList (MalFunc (FuncT f) : rest)) -> + return $ f $ MalList rest + el -> + error $ "invalid apply: " ++ (show el) + +eval :: MalVal -> (Map.Map String MalVal) -> 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 +add args = case args of + (MalList [MalNumber a, MalNumber b]) -> MalNumber $ a + b + _ -> error $ "illegal arguments to +" +sub args = case args of + (MalList [MalNumber a, MalNumber b]) -> MalNumber $ a - b + _ -> error $ "illegal arguments to -" +mult args = case args of + (MalList [MalNumber a, MalNumber b]) -> MalNumber $ a * b + _ -> error $ "illegal arguments to *" +divd args = case args of + (MalList [MalNumber a, MalNumber b]) -> MalNumber $ a `div` b + _ -> error $ "illegal arguments to /" + +repl_env :: Map.Map String MalVal +repl_env = Map.fromList [("+", _malfunc add), + ("-", _malfunc sub), + ("*", _malfunc mult), + ("/", _malfunc divd)] + +rep :: String -> IO String +rep line = do + ast <- mal_read line + exp <- eval ast repl_env + return $ mal_print exp + +repl_loop :: IO () +repl_loop = do + putStr "user> " + hFlush stdout + ineof <- hIsEOF stdin + when (not ineof) $ do + line <- hGetLine stdin + if null line + then repl_loop + else do + out <- catchAny (rep line) $ \e -> do + return $ "Error: " ++ (show e) + putStrLn out + repl_loop + +main = repl_loop diff --git a/haskell/step3_env.hs b/haskell/step3_env.hs new file mode 100644 index 0000000..58545cb --- /dev/null +++ b/haskell/step3_env.hs @@ -0,0 +1,115 @@ +import System.IO (hGetLine, hFlush, hIsEOF, stdin, stdout) +import Control.Monad (when, mapM) +import Control.Monad.Error (throwError) +import qualified Data.Map as Map +import qualified Data.Traversable as DT + +import Types +import Reader (read_str) +import Printer (_pr_str) +import Env (Env, env_new, env_get, env_set) + +-- read +mal_read :: String -> IO MalVal +mal_read str = read_str str + +-- eval +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 _) env = do + el <- eval_ast ast env + case el of + (MalList (MalFunc (FuncT f) : rest)) -> + return $ f $ MalList rest + 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 +add args = case args of + (MalList [MalNumber a, MalNumber b]) -> MalNumber $ a + b + _ -> error $ "illegal arguments to +" +sub args = case args of + (MalList [MalNumber a, MalNumber b]) -> MalNumber $ a - b + _ -> error $ "illegal arguments to -" +mult args = case args of + (MalList [MalNumber a, MalNumber b]) -> MalNumber $ a * b + _ -> error $ "illegal arguments to *" +divd args = case args of + (MalList [MalNumber a, MalNumber b]) -> MalNumber $ a `div` b + _ -> error $ "illegal arguments to /" + +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 + putStr "user> " + hFlush stdout + ineof <- hIsEOF stdin + when (not ineof) $ do + line <- hGetLine stdin + if null line + then repl_loop env + else do + out <- catchAny (rep env line) $ \e -> do + return $ "Error: " ++ (show e) + putStrLn out + repl_loop env + +main = do + repl_env <- env_new Nothing + env_set repl_env (MalSymbol "+") $ _malfunc add + env_set repl_env (MalSymbol "-") $ _malfunc sub + env_set repl_env (MalSymbol "*") $ _malfunc mult + env_set repl_env (MalSymbol "/") $ _malfunc divd + repl_loop repl_env -- cgit v1.2.3