implement let
This commit is contained in:
gilch
parent
db210929d0
commit
34038ff433
@ -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]
|
||||
(if (instance? HyExpression x)
|
||||
(macroexpand x)
|
||||
x))
|
||||
form))
|
||||
(setv quote-level [0]) ; TODO: make nonlocal after dropping Python2
|
||||
(defn traverse [form]
|
||||
(walk expand identity form))
|
||||
(defn expand [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',]
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user