implement let

hy/contrib/walk.hy

@@ -4,7 +4,8 @@
 ;; license. See the LICENSE.
 
 (import [hy [HyExpression HyDict]]
-        [functools [partial]])
+        [functools [partial]]
+        [collections [OrderedDict]])
 
 (defn walk [inner outer form]
   "Traverses form, an arbitrary data structure. Applies inner to each
@@ -34,10 +35,259 @@
   sub-form, uses f's return value in place of the original."
   (walk (partial prewalk f) identity (f form)))
 
+(defn call? [form]
+  "Checks whether form is a non-empty HyExpression"
+  (and (instance? HyExpression form)
+       form))
+
 (defn macroexpand-all [form]
   "Recursively performs all possible macroexpansions in form."
-  (prewalk (fn [x]
+  (setv quote-level [0])  ; TODO: make nonlocal after dropping Python2
-             (if (instance? HyExpression x)
+  (defn traverse [form]
-               (macroexpand x)
+    (walk expand identity form))
-               x))
+  (defn expand [form]
-           form))
+    ;; manages quote levels
+    (defn +quote [&optional [x 1]]
+      (setv head (first form))
+      (+= (get quote-level 0) x)
+      (when (neg? (get quote-level 0))
+        (raise (TypeError "unquote outside of quasiquote")))
+      (setv res (traverse (cut form 1)))
+      (-= (get quote-level 0) x)
+      `(~head ~@res))
+    (if (call? form)
+      (cond [(get quote-level 0)
+             (cond [(in (first form) '[unquote unquote-splice])
+                    (+quote -1)]
+                   [(= (first form) 'quasiquote) (+quote)]
+                   [True (traverse form)])]
+            [(= (first form) 'quote) form]
+            [(= (first form) 'quasiquote) (+quote)]
+            [True (traverse (macroexpand form))])
+      (if (coll? form)
+        (traverse form)
+        form)))
+  (expand form))
+
+(setv special-forms (list-comp k
+                               [k (.keys hy.compiler._compile-table)]
+                               (isinstance k hy._compat.string-types)))
+
+
+(defn lambda-list [form]
+  "
+splits a fn argument list into sections based on &-headers.
+
+returns an OrderedDict mapping headers to sublists.
+Arguments without a header are under None.
+"
+  (setv headers '[&optional &key &rest &kwonly &kwargs]
+        sections (OrderedDict [(, None [])])
+        header None)
+  (for [arg form]
+    (if (in arg headers)
+      (do (setv header arg)
+          (assoc sections header [])
+          ;; Don't use a header more than once. It's the compiler's problem.
+          (.remove headers header))
+      (.append (get sections header) arg)))
+  sections)
+
+(defmacro let [bindings &rest body]
+  "
+sets up lexical bindings in its body
+
+Bindings are processed sequentially,
+so you can use the result of a earlier binding in a later one.
+
+Basic assignments (e.g. setv, +=) will update the let binding,
+if they use the name of a let binding.
+
+But assignments via `import` are always hoisted to normal Python scope, and
+likewise, `defclass` will assign the class to the Python scope,
+even if it shares the name of a let binding.
+
+Use __import__ and type (or whatever metaclass) instead,
+if you must avoid this hoisting.
+
+Function arguments can shadow let bindings in their body,
+as can nested let forms.
+"
+  ;; I'd use defmacro/g!, but it loses the docstring hylang/hy#1424
+  (setv g!let (gensym 'let))
+  (if (odd? (len bindings))
+      (macro-error bindings "let bindings must be paired"))
+  ;; pre-expanding the body means we only have to worry about a small number
+  ;; of special forms
+  (setv body (macroexpand-all body)
+        bound-symbols (cut bindings None None 2)
+        quote-level [0])
+  (for [k bound-symbols]
+    (if-not (symbol? k)
+            (macro-error k "let can only bind to symbols")
+            (if (in '. k)
+                (macro-error k "let binding symbols may not contain a dot"))))
+  ;; sets up the recursion call
+  (defn expand-symbols [protected-symbols form]
+    (defn traverse [form &optional [protected-symbols protected-symbols]]
+      (walk (partial expand-symbols protected-symbols)
+            identity
+            form))
+    ;; manages quote levels
+    (defn +quote [&optional [x 1]]
+      (setv head (first form))
+      (+= (get quote-level 0) x)
+      (setv res (traverse (cut form 1)))
+      (-= (get quote-level 0) x)
+      `(~head ~@res))
+    (cond [(get quote-level 0)  ; don't expand symbols in quotations
+           (if (call? form)
+               (cond [(in (first form) '[unquote unquote-splice])
+                      (+quote -1)]
+                     [(= (first form) 'quasiquote)
+                      (+quote)]
+                     [True (traverse form)])
+               (if (coll? form)
+                   (traverse form)
+                   form))]
+          ;; symbol expansions happen here.
+          [(symbol? form)
+           (if (and form
+                    (not (.startswith form '.))
+                    (in '. form))
+               ;; convert dotted names to the standard special form
+               (expand-symbols protected-symbols
+                               `(. ~@(map HySymbol (.split form '.))))
+               ;; else expand if applicable
+               (if (and (in form bound-symbols)
+                        (not-in form protected-symbols))
+                   `(get ~g!let ~(name form))
+                   form))]
+          ;; We have to treat special forms differently.
+          ;; Quotation should suppress symbol expansion,
+          ;; and local bindings should shadow those made by let.
+          [(call? form)
+           (setv head (first form))
+           (setv tail (cut form 1))
+           (cond [(in head '[fn fn*])
+                  ;; TODO: handle globals, locals
+                  (setv body (cut tail 1)
+                        protected #{}
+                        fn-bindings `[])
+                  (for [[header section] (-> tail first lambda-list .items)]
+                    (if header (.append fn-bindings header))
+                    (cond [(in header [None '&rest '&kwargs])
+                           (.update protected (-> section flatten set))
+                           (.extend fn-bindings section)]
+                          [(in header '[&optional &kwonly])
+                           (for [pair section]
+                             (cond [(coll? pair)
+                                    (.add protected (first pair))
+                                    (.append fn-bindings
+                                             `[~(first pair)
+                                               ~(expand-symbols protected-symbols
+                                                                (second pair))])]
+                                   [True
+                                    (.add protected pair)
+                                    (.append fn-bindings pair)]))]
+                          [(= header '&key)
+                           (setv &key-dict '{})
+                           (for [[k v] (-> section first partition)]
+                             (.add protected k)
+                             (.append &key-dict k)
+                             (.append &key-dict (expand-symbols protected-symbols
+                                                                v)))
+                           (.append fn-bindings &key-dict)]))
+                  `(~head ~fn-bindings
+                    ~@(traverse body (| protected protected-symbols)))]
+                 [(= head 'except)
+                  ;; protect the "as" name binding the exception
+                  `(~head ~@(traverse tail (| protected-symbols
+                                              (if (and tail
+                                                       (-> tail
+                                                           first
+                                                           len
+                                                           (= 2)))
+                                                  #{(first (first tail))}
+                                                  #{}))))]
+                 [(= head ".")
+                  `(. ~@(walk (fn [form]
+                                (if (symbol? form)
+                                    form  ; don't expand attrs
+                                    (expand-symbols protected-symbols
+                                                    form)))
+                              identity
+                              tail))]
+                 [(in head '[import quote]) form]
+                 [(= head 'defclass)
+                  ;; don't expand the name of the class
+                  `(~head ~(first tail) ~@(traverse (cut tail 1)))]
+                 [(= head 'quasiquote) (+quote)]
+                 ;; don't expand other special form symbols in head position
+                 [(in head special-forms) `(~head ~@(traverse tail))]
+                 ;; Not a special form. Traverse it like a coll
+                 [True (traverse form)])]
+          [(coll? form) (traverse form)]
+          ;; recursive base case--it's an atom. Put it back.
+          [True form]))
+  (expand-symbols #{}
+                   `(do
+                      (setv ~g!let {}
+                            ~@bindings)
+                      ~@body)))
+
+#_[special cases for let
+   ;; this means we can't use a list for our let scope
+   ;; we're using a dict instead.
+   'del',
+
+   ;; Symbols containing a dot should be converted to this form.
+   ;; attrs should not get expanded,
+   ;; but [] lookups should.
+   '.',
+
+   ;;; can shadow let bindings with Python locals
+   ;; protect its bindings for the lexical scope of its body.
+   'fn',
+   'fn*',
+   ;; protect as bindings for the lexical scope of its body
+   'except',
+
+   ;;; changes scope of named variables
+   ;; protect the variables they name for the lexical scope of their container
+   'global',
+   'nonlocal',
+   ;; should we provide a protect form?
+   ;; it's an anaphor only valid in a `let` body.
+   ;; this would make the named variables python-scoped in its body
+   ;; expands to a do
+   'protect',
+
+   ;;; quoted variables must not be expanded.
+   ;; but unprotected, unquoted variables must be.
+   'quasiquote',
+   'quote',
+   'unquote',
+   'unquote-splice',
+
+   ;;;; deferred
+
+   ;; should really only exist at toplevel. Ignore until someone complains?
+   ;; raise an error? treat like fn?
+   ;; should probably be implemented as macros in terms of fn/setv anyway.
+   'defmacro',
+   'deftag',
+
+   ;;; create Python-scoped variables. It's probably hard to avoid this.
+   ;; Best just doc this behavior for now.
+   ;; we can't avoid clobbering enclosing python scope, unless we use a gensym,
+   ;; but that corrupts '__name__'.
+   ;; It could be set later, but that could mess up metaclasses!
+   ;; Should the class name update let variables too?
+   'defclass',
+   ;; should this update let variables?
+   ;; it could be done with gensym/setv.
+   'import',
+
+   ;; I don't understand these. Ignore until someone complains?
+   'eval_and_compile', 'eval_when_compile', 'require',]

tests/native_tests/contrib/walk.hy

@@ -3,6 +3,7 @@
 ;; license. See the LICENSE.
 
 (import [hy.contrib.walk [*]])
+(require [hy.contrib.walk [*]])
 
 (def walk-form '(print {"foo" "bar"
                         "array" [1 2 3 [4]]
@@ -35,5 +36,251 @@
              [[2 [3 [4]] 2 [3 [4]]]])))
 
 (defn test-macroexpand-all []
+  (assert (= (macroexpand-all '(with [a 1]))
+             '(with* [a 1] (do))))
   (assert (= (macroexpand-all '(with [a 1 b 2 c 3] (for [d c] foo)))
-             '(with* [a 1] (with* [b 2] (with* [c 3] (do (for* [d c] (do foo)))))))))
+             '(with* [a 1] (with* [b 2] (with* [c 3] (do (for* [d c] (do foo))))))))
+  (assert (= (macroexpand-all '(with [a 1]
+                                 '(with [b 2])
+                                 `(with [c 3]
+                                    ~(with [d 4])
+                                    ~@[(with [e 5])])))
+             '(with* [a 1]
+                (do '(with [b 2])
+                    `(with [c 3]
+                       ~(with* [d 4] (do))
+                       ~@[(with* [e 5] (do))]))))))
+
+(defn test-let-basic []
+  (assert (zero? (let [a 0] a)))
+  (setv a "a"
+        b "b")
+  (let [a "x"
+        b "y"]
+       (assert (= (+ a b)
+                  "xy"))
+       (let [a "z"]
+            (assert (= (+ a b)
+                       "zy")))
+       ;; let-shadowed variable doesn't get clobbered.
+       (assert (= (+ a b)
+                  "xy")))
+  (let [q "q"]
+       (assert (= q "q")))
+  (assert (= a "a"))
+  (assert (= b "b"))
+  (assert (in "a" (.keys (vars))))
+  ;; scope of q is limited to let body
+  (assert (not-in "q" (.keys (vars)))))
+
+(defn test-let-sequence []
+  (let [a "a"
+        b "b"
+        ab (+ a b)]
+       (assert (= ab "ab"))
+       (let [c "c"
+             abc (+ ab c)]
+            (assert (= abc "abc")))))
+
+(defn test-let-special []
+  ;; special forms in function position still work as normal
+  (let [, 1]
+       (assert (= (, , ,)
+                  (, 1 1)))))
+
+(defn test-let-quasiquote []
+  (setv a-symbol 'a)
+  (let [a "x"]
+       (assert (= a "x"))
+       (assert (= 'a a-symbol))
+       (assert (= `a a-symbol))
+       (assert (= `(foo ~a)
+                  '(foo "x")))
+       (assert (= `(foo `(bar a ~a ~~a))
+                  '(foo `(bar a ~a ~"x"))))
+       (assert (= `(foo ~@[a])
+                  '(foo "x")))
+       (assert (= `(foo `(bar [a] ~@[a] ~@~[a 'a `a] ~~@[a]))
+                  '(foo `(bar [a] ~@[a] ~@["x" a a] ~"x"))))))
+
+(defn test-let-except []
+  (let [foo 42
+        bar 33]
+       (assert (= foo 42))
+       (try
+         (do
+           1/0
+           (assert False))
+         (except [foo Exception]
+           ;; let bindings should work in except block
+           (assert (= bar 33))
+           ;; but exception bindings can shadow let bindings
+           (assert (instance? Exception foo))))
+       ;; let binding did not get clobbered.
+       (assert (= foo 42))))
+
+(defn test-let-mutation []
+  (setv foo 42)
+  (setv error False)
+  (let [foo 12
+        bar 13]
+       (assert (= foo 12))
+       (setv foo 14)
+       (assert (= foo 14))
+       (del foo)
+       ;; deleting a let binding should not affect others
+       (assert (= bar 13))
+       (try
+         ;; foo=42 is still shadowed, but the let binding was deleted.
+         (do
+           foo
+           (assert False))
+         (except [ke LookupError]
+           (setv error ke)))
+       (setv foo 16)
+       (assert (= foo 16))
+       (setv [foo bar baz] [1 2 3])
+       (assert (= foo 1))
+       (assert (= bar 2))
+       (assert (= baz 3)))
+  (assert error)
+  (assert (= foo 42))
+  (assert (= baz 3)))
+
+(defn test-let-break []
+  (for [x (range 3)]
+    (let [done (odd? x)]
+         (if done (break))))
+  (assert (= x 1)))
+
+(defn test-let-yield []
+  (defn grind []
+    (yield 0)
+    (let [a 1
+          b 2]
+         (yield a)
+         (yield b)))
+  (assert (= (tuple (grind))
+             (, 0 1 2))))
+
+(defn test-let-return []
+  (defn get-answer []
+    (let [answer 42]
+         (return answer)))
+  (assert (= (get-answer)
+             42)))
+
+(defn test-let-import []
+  (let [types 6]
+       ;; imports don't fail, even if using a let-bound name
+       (import types)
+       ;; let-bound name is not affected
+       (assert (= types 6)))
+  ;; import happened in Python scope.
+  (assert (in "types" (vars)))
+  (assert (instance? types.ModuleType types)))
+
+(defn test-let-defclass []
+  (let [Foo 42
+        quux object]
+       ;; the name of the class is just a symbol, even if it's a let binding
+       (defclass Foo [quux]  ; let bindings apply in inheritance list
+         ;; let bindings apply inside class body
+         (setv x Foo)))
+  ;; defclass always creates a python-scoped variable, even if it's a let binding name
+  (assert (= Foo.x 42)))
+
+(defn test-let-dot []
+  (setv foo (fn [])
+        foo.a 42)
+  (let [a 1
+        b []]
+       (assert (= a 1))
+       (assert (= b []))
+       ;; method syntax not affected
+       (.append b 2)
+       (assert (= b [2]))
+       ;; attrs access is not affected
+       (assert (= foo.a 42))
+       (assert (= (. foo a)
+                  42))
+       ;; but indexing is
+       (assert (= (. [1 2 3]
+                     [a])
+                  2))))
+
+(defn test-let-positional []
+  (let [a 0
+        b 1
+        c 2]
+       (defn foo [a b]
+         (, a b c))
+       (assert (= (foo 100 200)
+                  (, 100 200 2)))
+       (setv c 300)
+       (assert (= (foo 1000 2000)
+                  (, 1000 2000 300)))
+       (assert (= a 0))
+       (assert (= b 1))
+       (assert (= c 300))))
+
+(defn test-let-rest []
+  (let [xs 6
+        a 88
+        c 64
+        &rest 12]
+       (defn foo [a b &rest xs]
+         (-= a 1)
+         (-= c 1)
+         (setv xs (list xs))
+         (.append xs 42)
+         (, &rest a b c xs))
+       (assert (= xs 6))
+       (assert (= a 88))
+       (assert (= (foo 1 2 3 4)
+                  (, 12 0 2 63 [3 4 42])))
+       (assert (= xs 6))
+       (assert (= c 63))
+       (assert (= a 88))))
+
+(defn test-let-kwargs []
+  (let [kws 6
+        &kwargs 13]
+       (defn foo [&kwargs kws]
+         (, &kwargs kws))
+       (assert (= kws 6))
+       (assert (= (foo :a 1)
+                  (, 13 {"a" 1})))))
+
+(defn test-let-optional []
+  (let [a 1
+        b 6
+        d 2]
+       (defn foo [&optional [a a] b [c d]]
+         (, a b c))
+       (assert (= (foo)
+                  (, 1 None 2)))
+       (assert (= (foo 10 20 30)
+                  (, 10 20 30)))))
+
+(defn test-let-key []
+  (let [a 1
+        b 6
+        d 2]
+       (defn foo [&key {a a b None c d}]
+         (, a b c))
+       (assert (= (foo)
+                  (, 1 None 2)))
+       (assert (= (foo 10 20 30)
+                  (, 10 20 30)))
+       (assert (= (, a b d)
+                  (, 1 6 2)))))
+;; TODO
+;; test-let-continue
+;; test-let-closure
+;; test-let-global
+
+;; TODO
+;;; Python 3 only
+;; test-let-nonlocal
+;; test-let-kwonly