haskell/step6_file.hs

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