Skip to content

Commit

Permalink
refactor let symbol expansion to a class
Browse files Browse the repository at this point in the history
  • Loading branch information
@gilch
gilch committed Sep 19, 2017
1 parent 20b4342 commit 1272955
Showing 1 changed file with 171 additions and 111 deletions.
282 changes: 171 additions & 111 deletions hy/contrib/walk.hy
View file
Original file line number Diff line number Diff line change
Expand Up @@ -93,6 +93,169 @@ Arguments without a header are under None.
(.append (get sections header) arg)))
sections)

(defclass SymbolExpander[]
(defn expand-symbols [self protected form]
(.expand (SymbolExpander form self.expander protected self.quote-level)))

(defn __init__ [self form expander &optional protected [quote-level 0]]
(setv self.form form
self.expander expander
self.protected (if (none? protected)
#{}
protected)
self.quote-level quote-level))

(defn traverse [self form &optional protected]
(if (none? protected)
(setv protected self.protected))
(walk (partial self.expand-symbols protected)
identity
form))

;; manages quote levels
(defn +quote [self &optional [x 1]]
(setv head (self.head))
(+= self.quote-level x)
(setv tail (self.traverse (self.tail)))
(-= self.quote-level x)
`(~head ~@tail))

(defn handle-dot [self]
`(. ~@(walk (fn [form]
(if (symbol? form)
form ; don't expand attrs
(self.expand-symbols self.protected
form)))
identity
(self.tail))))

(defn head [self]
(first self.form))

(defn tail [self]
(cut self.form 1))

(defn handle-except [self]
(setv tail (self.tail))
;; protect the "as" name binding the exception
`(~(self.head) ~@(self.traverse tail (| self.protected
(if (and tail
(-> tail
first
len
(= 2)))
#{(first (first tail))}
#{})))))
(defn handle-fn [self]
(setv body (cut (self.tail) 1)
tail (self.tail)
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)
~(self.expand-symbols self.protected
(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 (self.expand-symbols self.protected
v)))
(.append fn-bindings &key-dict)]))
`(~(self.head) ~fn-bindings
~@(self.traverse body (| protected self.protected))))

;; don't expand symbols in quotations
(defn handle-quoted [self]
(setv form self.form)
(if (call? form)
(cond [(in (first form) '[unquote unquote-splice])
(self.+quote -1)]
[(= (first form) 'quasiquote)
(self.+quote)]
[True (self.traverse form)])
(if (coll? form)
(self.traverse form)
form)))

;; convert dotted names to the standard special form
(defn convert-dotted-symbol [self]
(self.expand-symbols self.protected
`(. ~@(map HySymbol (.split self.form '.)))))

(defn expand-symbol [self]
(if (not-in self.form self.protected)
(self.expander self.form)
self.form))

;; symbol expansions happen here.
(defn handle-symbol [self]
(if (and self.form
(not (.startswith self.form '.))
(in '. self.form))
(self.convert-dotted-symbol)
(self.expand-symbol)))

(defn handle-global [self]
(print "handle-global")
(.update self.protected (set (self.tail)))
self.form)

(defn handle-defclass [self]
;; don't expand the name of the class
`(~(self.head) ~(first (self.tail))
~@(self.traverse (cut (self.tail) 1))))

(defn handle-special-form [self]
;; don't expand other special form symbols in head position
`(~(self.head) ~@(self.traverse (self.tail))))

(defn handle-base [self]
self.form)

(defn handle-coll [self]
(self.traverse self.form))

;; We have to treat special forms differently.
;; Quotation should suppress symbol expansion,
;; and local bindings should shadow those made by let.
(defn handle-call [self]
(setv head (first self.form))
(if (in head '[fn fn*]) (self.handle-fn)
(in head '[import quote]) (self.handle-base)
(= head 'except) (self.handle-except)
(= head ".") (self.handle-dot)
(= head 'global) (self.handle-global)
(= head 'defclass) (self.handle-defclass)
(= head 'quasiquote) (self.+quote)
;; must be checked last!
(in head special-forms) (self.handle-special-form)
;; Not a special form. Traverse it like a coll
(self.handle-coll)))

(defn expand [self]
"the main entry point. Call this to do the expansion"
(setv form self.form)
(if self.quote-level (self.handle-quoted)
(symbol? form) (self.handle-symbol)
(call? form) (self.handle-call)
(coll? form) (self.handle-coll)
;; recursive base case--it's an atom. Put it back.
(self.handle-base))))

(defmacro let [bindings &rest body]
"
sets up lexical bindings in its body
Expand Down Expand Up @@ -120,122 +283,19 @@ as can nested let forms.
;; 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])
bound-symbols (cut bindings None None 2))
(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))
(HySymbol (+ g!let "::" 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*])
(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))]
[(= head 'global)
(.update protected-symbols (set tail))
form]
[(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 ~@bindings)
~@body)))
(.expand (SymbolExpander `(do
(setv ~@bindings)
~@body)
(fn [symbol]
(if (in symbol bound-symbols)
(HySymbol (+ g!let "::" symbol))
symbol)))))

#_[special cases for let
;; Symbols containing a dot should be converted to this form.
Expand Down

0 comments on commit 1272955

Please sign in to comment.