haskell/step3_env.hs

   1 import System.IO (hFlush, stdout)
   2 import Control.Monad ((<=<))
   3 import Control.Monad.Except (runExceptT)
   4 import Control.Monad.Trans (liftIO)
   5
   6 import Readline (addHistory, readline, load_history)
   7 import Types
   8 import Reader (read_str)
   9 import Printer (_pr_str)
  10 import Env (env_new, env_get, env_set)
  11
  12 -- read
  13
  14 mal_read :: String -> IOThrows MalVal
  15 mal_read = read_str
  16
  17 -- eval
  18
  19 -- eval_ast is replaced with pattern matching.
  20
  21 let_bind :: Env -> [MalVal] -> IOThrows ()
  22 let_bind _ [] = return ()
  23 let_bind env (MalSymbol b : e : xs) = do
  24     liftIO . env_set env b =<< eval env e
  25     let_bind env xs
  26 let_bind _ _ = throwStr "invalid let*"
  27
  28 apply_ast :: [MalVal] -> Env -> IOThrows MalVal
  29
  30 apply_ast [] _ = return $ toList []
  31
  32 apply_ast [MalSymbol "def!", MalSymbol a1, a2] env = do
  33     evd <- eval env a2
  34     liftIO $ env_set env a1 evd
  35     return evd
  36 apply_ast (MalSymbol "def!" : _) _ = throwStr "invalid def!"
  37
  38 apply_ast [MalSymbol "let*", MalSeq _ _ params, a2] env = do
  39     let_env <- liftIO $ env_new env
  40     let_bind let_env params
  41     eval let_env a2
  42 apply_ast (MalSymbol "let*" : _) _ = throwStr "invalid let*"
  43
  44 apply_ast ast env = do
  45     evd <- mapM (eval env) ast
  46     case evd of
  47         MalFunction {fn=f} : args -> f args
  48         _ -> throwStr . (++) "invalid apply: " =<< liftIO (Printer._pr_str True (toList ast))
  49
  50 eval :: Env -> MalVal -> IOThrows MalVal
  51 eval env (MalSymbol sym)            = do
  52     maybeVal <- liftIO $ env_get env sym
  53     case maybeVal of
  54         Nothing  -> throwStr $ "'" ++ sym ++ "' not found"
  55         Just val -> return val
  56 eval env (MalSeq _ (Vect False) xs) = apply_ast xs env
  57 eval env (MalSeq m (Vect True)  xs) = MalSeq m (Vect True) <$> mapM (eval env) xs
  58 eval env (MalHashMap m xs)          = MalHashMap m         <$> mapM (eval env) xs
  59 eval _   ast                        = return ast
  60
  61 -- print
  62
  63 mal_print :: MalVal -> IOThrows String
  64 mal_print = liftIO. Printer._pr_str True
  65
  66 -- repl
  67
  68 add :: Fn
  69 add [MalNumber a, MalNumber b] = return $ MalNumber $ a + b
  70 add _ = throwStr $ "illegal arguments to +"
  71
  72 sub :: Fn
  73 sub [MalNumber a, MalNumber b] = return $ MalNumber $ a - b
  74 sub _ = throwStr $ "illegal arguments to -"
  75
  76 mult :: Fn
  77 mult [MalNumber a, MalNumber b] = return $ MalNumber $ a * b
  78 mult _ = throwStr $ "illegal arguments to *"
  79
  80 divd :: Fn
  81 divd [MalNumber a, MalNumber b] = return $ MalNumber $ a `div` b
  82 divd _ = throwStr $ "illegal arguments to /"
  83
  84 rep :: Env -> String -> IOThrows String
  85 rep env = mal_print <=< eval env <=< mal_read
  86
  87 repl_loop :: Env -> IO ()
  88 repl_loop env = do
  89     line <- readline "user> "
  90     case line of
  91         Nothing -> return ()
  92         Just "" -> repl_loop env
  93         Just str -> do
  94             addHistory str
  95             res <- runExceptT $ rep env str
  96             out <- case res of
  97                 Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv)
  98                 Right val -> return val
  99             putStrLn out
 100             hFlush stdout
 101             repl_loop env
 102
 103 defBuiltIn :: Env -> String -> Fn -> IO ()
 104 defBuiltIn env sym f =
 105     env_set env sym $ MalFunction {fn=f, f_ast=Nil, f_params=[], macro=False, meta=Nil}
 106
 107 main :: IO ()
 108 main = do
 109     load_history
 110
 111     repl_env <- env_new []
 112
 113     defBuiltIn repl_env "+" add
 114     defBuiltIn repl_env "-" sub
 115     defBuiltIn repl_env "*" mult
 116     defBuiltIn repl_env "/" divd
 117
 118     repl_loop repl_env