haskell/step4_if_fn_do.hs

   1 import System.IO (hFlush, stdout)
   2 import Control.Monad ((<=<))
   3 import Control.Monad.Except (runExceptT)
   4 import Control.Monad.Trans (liftIO)
   5 import Data.Foldable (foldlM)
   6
   7 import Readline (addHistory, readline, load_history)
   8 import Types
   9 import Reader (read_str)
  10 import Printer (_pr_str)
  11 import Env (env_new, env_bind, env_get, env_set)
  12 import Core (ns)
  13
  14 -- read
  15
  16 mal_read :: String -> IOThrows MalVal
  17 mal_read = read_str
  18
  19 -- eval
  20
  21 -- eval_ast is replaced with pattern matching.
  22
  23 let_bind :: Env -> [MalVal] -> IOThrows ()
  24 let_bind _ [] = return ()
  25 let_bind env (MalSymbol b : e : xs) = do
  26     liftIO . env_set env b =<< eval env e
  27     let_bind env xs
  28 let_bind _ _ = throwStr "invalid let*"
  29
  30 unWrapSymbol :: MalVal -> IOThrows String
  31 unWrapSymbol (MalSymbol s) = return s
  32 unWrapSymbol _ = throwStr "fn* parameter must be symbols"
  33
  34 newFunction :: MalVal -> Env -> [String] -> MalVal
  35 newFunction a env p = MalFunction {f_ast=a, f_params=p, macro=False, meta=Nil,
  36     fn=(\args -> do
  37         fn_env <- liftIO $ env_new env
  38         ok <- liftIO $ env_bind fn_env p args
  39         case ok of
  40             True  -> eval fn_env a
  41             False -> throwStr $ "actual parameters do not match signature " ++ show p)}
  42
  43 apply_ast :: [MalVal] -> Env -> IOThrows MalVal
  44
  45 apply_ast [] _ = return $ toList []
  46
  47 apply_ast [MalSymbol "def!", MalSymbol a1, a2] env = do
  48     evd <- eval env a2
  49     liftIO $ env_set env a1 evd
  50     return evd
  51 apply_ast (MalSymbol "def!" : _) _ = throwStr "invalid def!"
  52
  53 apply_ast [MalSymbol "let*", MalSeq _ _ params, a2] env = do
  54     let_env <- liftIO $ env_new env
  55     let_bind let_env params
  56     eval let_env a2
  57 apply_ast (MalSymbol "let*" : _) _ = throwStr "invalid let*"
  58
  59 apply_ast (MalSymbol "do" : args) env = foldlM (const $ eval env) Nil args
  60
  61 apply_ast [MalSymbol "if", a1, a2, a3] env = do
  62     cond <- eval env a1
  63     eval env $ case cond of
  64         Nil              -> a3
  65         MalBoolean False -> a3
  66         _                -> a2
  67 apply_ast [MalSymbol "if", a1, a2] env = do
  68     cond <- eval env a1
  69     case cond of
  70         Nil              -> return Nil
  71         MalBoolean False -> return Nil
  72         _                -> eval env a2
  73 apply_ast (MalSymbol "if" : _) _ = throwStr "invalid if"
  74
  75 apply_ast [MalSymbol "fn*", MalSeq _ _ params, ast] env = newFunction ast env <$> mapM unWrapSymbol params
  76 apply_ast (MalSymbol "fn*" : _) _ = throwStr "invalid fn*"
  77
  78 apply_ast ast env = do
  79     evd <- mapM (eval env) ast
  80     case evd of
  81         MalFunction {fn=f} : args -> f args
  82         _ -> throwStr . (++) "invalid apply: " =<< liftIO (Printer._pr_str True (toList ast))
  83
  84 eval :: Env -> MalVal -> IOThrows MalVal
  85 eval env (MalSymbol sym)            = do
  86     maybeVal <- liftIO $ env_get env sym
  87     case maybeVal of
  88         Nothing  -> throwStr $ "'" ++ sym ++ "' not found"
  89         Just val -> return val
  90 eval env (MalSeq _ (Vect False) xs) = apply_ast xs env
  91 eval env (MalSeq m (Vect True)  xs) = MalSeq m (Vect True) <$> mapM (eval env) xs
  92 eval env (MalHashMap m xs)          = MalHashMap m         <$> mapM (eval env) xs
  93 eval _   ast                        = return ast
  94
  95 -- print
  96
  97 mal_print :: MalVal -> IOThrows String
  98 mal_print = liftIO. Printer._pr_str True
  99
 100 -- repl
 101
 102 rep :: Env -> String -> IOThrows String
 103 rep env = mal_print <=< eval env <=< mal_read
 104
 105 repl_loop :: Env -> IO ()
 106 repl_loop env = do
 107     line <- readline "user> "
 108     case line of
 109         Nothing -> return ()
 110         Just "" -> repl_loop env
 111         Just str -> do
 112             addHistory str
 113             res <- runExceptT $ rep env str
 114             out <- case res of
 115                 Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv)
 116                 Right val -> return val
 117             putStrLn out
 118             hFlush stdout
 119             repl_loop env
 120
 121 --  Read and evaluate a line. Ignore successful results, but crash in
 122 --  case of error. This is intended for the startup procedure.
 123 re :: Env -> String -> IO ()
 124 re repl_env line = do
 125     res <- runExceptT $ eval repl_env =<< mal_read line
 126     case res of
 127         Left mv -> error . (++) "Startup failed: " <$> Printer._pr_str True mv
 128         Right _ -> return ()
 129
 130 defBuiltIn :: Env -> (String, Fn) -> IO ()
 131 defBuiltIn env (sym, f) =
 132     env_set env sym $ MalFunction {fn=f, f_ast=Nil, f_params=[], macro=False, meta=Nil}
 133
 134 main :: IO ()
 135 main = do
 136     load_history
 137
 138     repl_env <- env_new []
 139
 140     -- core.hs: defined using Haskell
 141     mapM_ (defBuiltIn repl_env) Core.ns
 142
 143     -- core.mal: defined using the language itself
 144     re repl_env "(def! not (fn* (a) (if a false true)))"
 145
 146     repl_loop repl_env