suzanne.soy/lens
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor define-nested-lenses

Browse Source 
to factor out handling definitions into the syntax class
This commit is contained in:
AlexKnauth 2015-12-04 23:28:59 -05:00
parent fa37f47add
commit 1f2241c3ce
1 changed files with 13 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
unstable/lens/define-nested.rkt
View File

@ -21,40 +21,31 @@ begin-for-syntax
(define -lens (update-source-location (datum->syntax #f '-lens)
#:span 5))
;; helper syntax-class for define-nested-lenses
(define-syntax-class (clause base-id)
(define-syntax-class (clause base-id base-lens-tmp)
#:attributes (def)
[pattern [suffix-id:id suffix-lens-expr:expr]
#:with base-lens:id base-lens-tmp
#:do [(define-values [base-suffix-lens-id sub-range-binders]
(id-append #:context base-id
base-id -- #'suffix-id -lens))]
#:with [base-suffix-lens ...]
(list base-suffix-lens-id)
#:with [suffix-lens ...]
(list #'suffix-lens-expr)
#:attr sub-range-binders
sub-range-binders])
#:with base-suffix-lens
base-suffix-lens-id
#:with def
(with-sub-range-binders
#`(define base-suffix-lens
(lens-thrush base-lens suffix-lens-expr))
sub-range-binders)])
(define-syntax define-nested-lenses
(syntax-parser
[(define-nested-lenses [base:id base-lens-expr:expr]
(~var clause (clause #'base))
(~parse base-lens:id (generate-temporary #'base))
(~var clause (clause #'base #'base-lens))
...)
#:with base-lens:id (generate-temporary #'base)
#:with [def ...]
(for/list ([base-suffix-lens-ids (in-list (syntax->list #'[[clause.base-suffix-lens] ... ...]))]
[suffix-lens-exprs (in-list (syntax->list #'[[clause.suffix-lens ...] ...]))]
[sub-range-binders-prop (in-list (attribute clause.sub-range-binders))])
(define/syntax-parse [base-suffix-lens ...] base-suffix-lens-ids)
(define/syntax-parse [suffix-lens ...] suffix-lens-exprs)
(with-sub-range-binders
#`(begin
(define base-suffix-lens
(lens-thrush base-lens suffix-lens))
...)
sub-range-binders-prop))
#'(begin
(define base-lens base-lens-expr)
def
clause.def
...)]))
module+ test