haskell/step8_macros.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, foldrM)
   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 -- starts-with is replaced with pattern matching.
  23
  24 qqIter :: Env -> MalVal -> [MalVal] -> IOThrows [MalVal]
  25 qqIter env (MalSeq _ (Vect False) [MalSymbol "splice-unquote", x]) acc = do
  26     evaluated <- eval env x
  27     case evaluated of
  28         MalSeq _ (Vect False) xs -> return $ xs ++ acc
  29         _ -> throwStr "invalid splice-unquote argument"
  30 qqIter _ (MalSeq _ (Vect False) (MalSymbol "splice-unquote" : _)) _ = throwStr "invalid splice-unquote"
  31 qqIter env x acc = (: acc) <$> quasiquote x env
  32
  33 quasiquote :: MalVal -> Env -> IOThrows MalVal
  34 quasiquote (MalSeq _ (Vect False) [MalSymbol "unquote", x]) env = eval env x
  35 --  FIXME This line
  36 quasiquote (MalSeq m _ ys) env = MalSeq m (Vect False) <$> foldrM (qqIter env) [] ys
  37 --  is adapted to broken tests. It should be:
  38 --  quasiquote (MalSeq m v ys) env = MalSeq m v <$> foldrM (qqIter env) [] ys
  39 quasiquote ast _ = return ast
  40
  41 -- is-macro-call is replaced with pattern matching.
  42
  43 macroexpand :: Env -> MalVal -> IOThrows MalVal
  44 macroexpand env ast@(MalSeq _ (Vect False) (MalSymbol a0 : args)) = do
  45     maybeMacro <- liftIO $ env_get env a0
  46     case maybeMacro of
  47         Just (MalFunction {fn=f, macro=True}) -> macroexpand env =<< f args
  48         _                                     -> return ast
  49 macroexpand _ ast = return ast
  50
  51 -- eval_ast is replaced with pattern matching.
  52
  53 let_bind :: Env -> [MalVal] -> IOThrows ()
  54 let_bind _ [] = return ()
  55 let_bind env (MalSymbol b : e : xs) = do
  56     liftIO . env_set env b =<< eval env e
  57     let_bind env xs
  58 let_bind _ _ = throwStr "invalid let*"
  59
  60 unWrapSymbol :: MalVal -> IOThrows String
  61 unWrapSymbol (MalSymbol s) = return s
  62 unWrapSymbol _ = throwStr "fn* parameter must be symbols"
  63
  64 newFunction :: MalVal -> Env -> [String] -> MalVal
  65 newFunction a env p = MalFunction {f_ast=a, f_params=p, macro=False, meta=Nil,
  66     fn=(\args -> do
  67         fn_env <- liftIO $ env_new env
  68         ok <- liftIO $ env_bind fn_env p args
  69         case ok of
  70             True  -> eval fn_env a
  71             False -> throwStr $ "actual parameters do not match signature " ++ show p)}
  72
  73 apply_ast :: [MalVal] -> Env -> IOThrows MalVal
  74
  75 apply_ast [] _ = return $ toList []
  76
  77 apply_ast [MalSymbol "def!", MalSymbol a1, a2] env = do
  78     evd <- eval env a2
  79     liftIO $ env_set env a1 evd
  80     return evd
  81 apply_ast (MalSymbol "def!" : _) _ = throwStr "invalid def!"
  82
  83 apply_ast [MalSymbol "let*", MalSeq _ _ params, a2] env = do
  84     let_env <- liftIO $ env_new env
  85     let_bind let_env params
  86     eval let_env a2
  87 apply_ast (MalSymbol "let*" : _) _ = throwStr "invalid let*"
  88
  89 apply_ast [MalSymbol "quote", a1] _ = return a1
  90 apply_ast (MalSymbol "quote" : _) _ = throwStr "invalid quote"
  91
  92 apply_ast [MalSymbol "quasiquote", a1] env = quasiquote a1 env
  93 apply_ast (MalSymbol "quasiquote" : _) _ = throwStr "invalid quasiquote"
  94
  95 apply_ast [MalSymbol "defmacro!", MalSymbol a1, a2] env = do
  96     func <- eval env a2
  97     case func of
  98         MalFunction {macro=False} -> do
  99             let m = func {macro=True}
 100             liftIO $ env_set env a1 m
 101             return m
 102         _ -> throwStr "defmacro! on non-function"
 103 apply_ast (MalSymbol "defmacro!" : _) _ = throwStr "invalid defmacro!"
 104
 105 apply_ast [MalSymbol "macroexpand", a1] env = macroexpand env a1
 106 apply_ast (MalSymbol "macroexpand" : _) _ = throwStr "invalid macroexpand"
 107
 108 apply_ast (MalSymbol "do" : args) env = foldlM (const $ eval env) Nil args
 109
 110 apply_ast [MalSymbol "if", a1, a2, a3] env = do
 111     cond <- eval env a1
 112     eval env $ case cond of
 113         Nil              -> a3
 114         MalBoolean False -> a3
 115         _                -> a2
 116 apply_ast [MalSymbol "if", a1, a2] env = do
 117     cond <- eval env a1
 118     case cond of
 119         Nil              -> return Nil
 120         MalBoolean False -> return Nil
 121         _                -> eval env a2
 122 apply_ast (MalSymbol "if" : _) _ = throwStr "invalid if"
 123
 124 apply_ast [MalSymbol "fn*", MalSeq _ _ params, ast] env = newFunction ast env <$> mapM unWrapSymbol params
 125 apply_ast (MalSymbol "fn*" : _) _ = throwStr "invalid fn*"
 126
 127 apply_ast ast env = do
 128     evd <- mapM (eval env) ast
 129     case evd of
 130         MalFunction {fn=f, macro=False} : args -> f args
 131         _ -> throwStr . (++) "invalid apply: " =<< liftIO (Printer._pr_str True (toList ast))
 132
 133 eval :: Env -> MalVal -> IOThrows MalVal
 134 eval env ast = do
 135     newAst <- macroexpand env ast
 136     case newAst of
 137         MalSymbol sym -> do
 138             maybeVal <- liftIO $ env_get env sym
 139             case maybeVal of
 140                 Nothing  -> throwStr $ "'" ++ sym ++ "' not found"
 141                 Just val -> return val
 142         MalSeq _ (Vect False) xs -> apply_ast xs env
 143         MalSeq m (Vect True)  xs -> MalSeq m (Vect True) <$> mapM (eval env) xs
 144         MalHashMap m xs          -> MalHashMap m         <$> mapM (eval env) xs
 145         _ -> return newAst
 146
 147 -- print
 148
 149 mal_print :: MalVal -> IOThrows String
 150 mal_print = liftIO. Printer._pr_str True
 151
 152 -- repl
 153
 154 rep :: Env -> String -> IOThrows String
 155 rep env = mal_print <=< eval env <=< mal_read
 156
 157 repl_loop :: Env -> IO ()
 158 repl_loop env = do
 159     line <- readline "user> "
 160     case line of
 161         Nothing -> return ()
 162         Just "" -> repl_loop env
 163         Just str -> do
 164             addHistory str
 165             res <- runExceptT $ rep env str
 166             out <- case res of
 167                 Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv)
 168                 Right val -> return val
 169             putStrLn out
 170             hFlush stdout
 171             repl_loop env
 172
 173 --  Read and evaluate a line. Ignore successful results, but crash in
 174 --  case of error. This is intended for the startup procedure.
 175 re :: Env -> String -> IO ()
 176 re repl_env line = do
 177     res <- runExceptT $ eval repl_env =<< mal_read line
 178     case res of
 179         Left mv -> error . (++) "Startup failed: " <$> Printer._pr_str True mv
 180         Right _ -> return ()
 181
 182 defBuiltIn :: Env -> (String, Fn) -> IO ()
 183 defBuiltIn env (sym, f) =
 184     env_set env sym $ MalFunction {fn=f, f_ast=Nil, f_params=[], macro=False, meta=Nil}
 185
 186 evalFn :: Env -> Fn
 187 evalFn env [ast] = eval env ast
 188 evalFn _ _ = throwStr "illegal call of eval"
 189
 190 main :: IO ()
 191 main = do
 192     args <- getArgs
 193     load_history
 194
 195     repl_env <- env_new []
 196
 197     -- core.hs: defined using Haskell
 198     mapM_ (defBuiltIn repl_env) Core.ns
 199     defBuiltIn repl_env ("eval", evalFn repl_env)
 200
 201     -- core.mal: defined using the language itself
 202     re repl_env "(def! not (fn* (a) (if a false true)))"
 203     re repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"
 204     re 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)))))))"
 205
 206     case args of
 207         script : scriptArgs -> do
 208             env_set repl_env "*ARGV*" $ toList $ MalString <$> scriptArgs
 209             re repl_env $ "(load-file \"" ++ script ++ "\")"
 210         [] -> do
 211             env_set repl_env "*ARGV*" $ toList []
 212             repl_loop repl_env