Hy: stepA (except meta on collections)

hy/core.hy

@@ -1,6 +1,7 @@
 (import [hy.models [HyKeyword :as Keyword HyString :as Str HySymbol :as Sym]])
 (import [copy [copy]])
-(import [mal_types [MalException Atom]])
+(import [time [time]])
+(import [mal_types [MalException Atom clone]])
 (import [reader [read-str]])
 (import [printer [pr-str]])
 
@@ -26,6 +27,7 @@
    "nil?"     none?
    "true?"    (fn [a] (and (instance? bool a) (= a True)))
    "false?"   (fn [a] (and (instance? bool a) (= a False)))
+   "string?"  (fn [a] (and (string? a) (not (keyword? a))))
    "symbol"   (fn [a] (Sym a))
    "symbol?"  (fn [a] (instance? Sym a))
    "keyword"  (fn [a] (Keyword (if (keyword? a) a (+ ":" a))))
@@ -36,6 +38,7 @@
    "prn"     (fn [&rest a] (print (.join " " (map (fn [e] (pr-str e True)) a))))
    "println" (fn [&rest a] (print (.join " " (map (fn [e] (pr-str e False)) a))))
    "read-string" read-str
+   "readline" (fn [a] (Str (raw_input a)))
    "slurp"   (fn [a] (Str (-> a open .read)))
 
    "<"  <
@@ -46,6 +49,7 @@
    "-"  -
    "*"  *
    "/"  (fn [a b] (int (/ a b)))
+   "time-ms"   (fn [] (int (* 1000 (time))))
 
    "list"      (fn [&rest args] (tuple args))
    "list?"     (fn [a] (instance? tuple a))
@@ -73,6 +77,14 @@
    "apply"  (fn [f &rest a] (apply f (+ (list (butlast a)) (list (last a)))))
    "map"    (fn [f a] (tuple (map f a)))
 
+   "conj"   (fn [a &rest xs] (if (instance? list a) (+ a (list xs))
+                                 (tuple (+ (tuple (reversed xs)) a))))
+   "seq"    (fn [a] (if (or (none? a) (empty? a)) None
+                        (string? a) (tuple (map Str a))
+                        (tuple a)))
+
+   "meta"   (fn [a] (if (hasattr a "meta") a.meta))
+   "with-meta" (fn [a b] (setv a (clone a)) (setv a.meta b) a)
    "atom"   (fn [a] (Atom a))
    "atom?"  (fn [a] (instance? Atom a))
    "deref"  (fn [a] a.val)

hy/mal_types.hy

@@ -1,6 +1,15 @@
+(import [types :as pytypes])
+
 (defclass MalException [Exception]
   (defn --init-- [self val] (setv self.val val)))
 
 (defclass Atom []
   (defn --init-- [self val] (setv self.val val)))
 
+(defn clone [obj]
+  (if (= (type obj) pytypes.FunctionType)
+    (pytypes.FunctionType obj.__code__ obj.__globals__
+                          :name obj.__name__
+                          :argdefs obj.__defaults__
+                          :closure obj.__closure__)
+    obj))

hy/stepA_mal.hy

@@ -0,0 +1,191 @@
+#!/usr/bin/env hy
+
+(import [hy.models [HyString :as Str HySymbol :as Sym]])
+(import sys traceback)
+(import [mal_types [MalException]])
+(import [reader [read-str Blank]])
+(import [printer [pr-str]])
+(import [env [env-new env-get env-set env-find]])
+(import core)
+
+;; read
+(defn READ [str]
+  (read-str str))
+
+;; eval
+(defn pair? [x]
+  (and (core.sequential? x) (> (len x) 0)))
+
+(defn QUASIQUOTE [ast]
+  (if
+    (not (pair? ast))
+    (tuple [(Sym "quote") ast])
+
+    (= (Sym "unquote") (first ast))
+    (nth ast 1)
+
+    (and (pair? (first ast))
+         (= (Sym "splice-unquote") (first (first ast))))
+    (tuple [(Sym "concat") (nth (first ast) 1) (QUASIQUOTE (tuple (rest ast)))])
+
+    True
+    (tuple [(Sym "cons") (QUASIQUOTE (first ast)) (QUASIQUOTE (tuple (rest ast)))])))
+
+(defn macro? [ast env]
+  (when (and (coll? ast)
+             (symbol? (first ast))
+             (env-find env (first ast)))
+    (setv mac (env-get env (first ast)))
+    (and (hasattr mac "macro")
+         mac.macro)))
+
+(defn macroexpand [ast env]
+ (while (macro? ast env)
+   (setv mac (env-get env (first ast))
+         ast (apply mac (tuple (rest ast)))))
+ ast)
+
+
+
+(defn eval-ast [ast env]
+  ;;(print "eval-ast:" ast (type ast))
+  (if
+    (symbol? ast)         (env-get env ast)
+    (instance? dict ast)  (dict (map (fn [k]
+                                       [(EVAL k env) (EVAL (get ast k) env)])
+                                     ast))
+    (instance? tuple ast) (tuple (map (fn [x] (EVAL x env)) ast))
+    (instance? list ast)  (list (map (fn [x] (EVAL x env)) ast))
+    True                  ast))
+
+(defn EVAL [ast env]
+  ;;(print "EVAL:" ast (type ast) (instance? tuple ast))
+  (setv res None)
+  (while True
+    (if (not (instance? tuple ast))
+      (setv res (eval-ast ast env))
+
+      ;; apply list
+      (do
+        (setv ast (macroexpand ast env))
+        (if (not (instance? tuple ast))
+          (setv res (eval-ast ast env))
+
+          (do
+            (setv [a0 a1 a2] [(nth ast 0) (nth ast 1) (nth ast 2)])
+            (if
+              (none? a0)
+              (setv res ast)
+
+              (= (Sym "def!") a0)
+              (setv res (env-set env a1 (EVAL a2 env)))
+
+              (= (Sym "let*") a0)
+              (do
+                (setv env (env-new env))
+                (for [[b e] (partition a1 2)]
+                  (env-set env b (EVAL e env)))
+                (setv ast a2)
+                (continue)) ;; TCO
+
+              (= (Sym "quote") a0)
+              (setv res a1)
+
+              (= (Sym "quasiquote") a0)
+              (do (setv ast (QUASIQUOTE a1)) (continue)) ;; TCO
+
+              (= (Sym "defmacro!") a0)
+              (do (setv func (EVAL a2 env)
+                        func.macro True)
+                  (setv res (env-set env a1 func)))
+
+              (= (Sym "macroexpand") a0)
+              (setv res (macroexpand a1 env))
+
+              (= (Sym "try*") a0)
+              (setv res
+                (if (= (Sym "catch*") (nth a2 0))
+                  (try
+                    (EVAL a1 env)
+                    (except [e Exception]
+                      (if (instance? MalException e)
+                        (setv exc e.val)
+                        (setv exc (Str (get e.args 0))))
+                      (EVAL (nth a2 2) (env-new env [(nth a2 1)]
+                                                    [exc]))))
+                  (EVAL a1 env)))
+
+              (= (Sym "do") a0)
+              (do (eval-ast (list (butlast (rest ast))) env)
+                  (setv ast (last ast))
+                  (continue)) ;; TCO
+
+              (= (Sym "if") a0)
+              (do
+                (setv cond (EVAL a1 env))
+                (if (or (none? cond) (and (instance? bool cond)
+                                          (= cond False)))
+                  (if (> (len ast) 2)
+                    (do (setv ast (nth ast 3)) (continue)) ;; TCO
+                    (setv res None))
+                  (do (setv ast a2) (continue)))) ;; TCO
+
+              (= (Sym "fn*") a0)
+              (setv func (fn [&rest args]
+                           (EVAL a2 (env-new env a1 (or args []))))
+                    func.ast a2
+                    func.env env
+                    func.params a1
+                    res func)
+
+              ;; apply
+              (do
+                (setv el (eval-ast ast env)
+                      f (first el)
+                      args (list (rest el)))
+                (if (hasattr f "ast")
+                  (do (setv ast f.ast
+                            env (env-new f.env f.params args))
+                      (continue)) ;; TCO
+                  (setv res (apply f args)))))))))
+    (break))
+  res)
+
+;; print
+(defn PRINT [exp]
+  (pr-str exp True))
+
+;; repl
+(def repl-env (env-new))
+(defn REP [str]
+  (PRINT (EVAL (READ str) repl-env)))
+
+;; core.hy: defined using Hy
+(for [k core.ns]
+  (env-set repl-env (Sym k) (get core.ns k)))
+(env-set repl-env (Sym "eval") (fn [ast] (EVAL ast repl-env)))
+(env-set repl-env (Sym "*ARGV*") (tuple (map Str (rest (rest sys.argv)))))
+
+;; core.mal: defined using the language itself
+(REP "(def! *host-language* \"Hy\")")
+(REP "(def! not (fn* [a] (if a false true)))")
+(REP "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
+(REP "(def! *gensym-counter* (atom 0))")
+(REP "(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))")
+(REP "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))")
+
+
+(when (>= (len sys.argv) 2)
+  (REP (+ "(load-file \"" (get sys.argv 1) "\")"))
+  (sys.exit 0)) 
+
+(REP "(println (str \"Mal [\" *host-language* \"]\"))")
+(while True
+  (try
+    (do (setv line (raw_input "user> "))
+        (if (= "" line) (continue))
+        (print (REP line)))
+    (except [EOFError] (break))
+    (except [Blank])
+    (except []
+      (print (.join "" (apply traceback.format_exception (.exc_info sys)))))))