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

Merge pull request #263 from AlexKnauth/define-nested-tree

Browse Source 
allow define-nested-lenses clauses to contain other clauses
This commit is contained in:
Alex Knauth 2015-12-05 01:03:31 -05:00
commit c2eb78522a
3 changed files with 78 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -21,48 +21,54 @@ 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)
[pattern [suffix-id:id suffix-lens-expr:expr]
#:do [(define-values [base-suffix-lens-id sub-range-binders]
(define-syntax-class (clause base-id base-lens-tmp)
#:attributes (def)
[pattern [suffix-id:id suffix-lens-expr:expr
unchecked-clause ...]
#:with base-lens:id base-lens-tmp
#:do [(define-values [base-suffix-id base-suffix-sub-range]
(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])
base-id -- #'suffix-id))
(define-values [base-suffix-lens-id base-suffix-lens-sub-range]
(id-append #:context base-id
base-suffix-id -lens))]
#:with base-suffix
base-suffix-id
#:with base-suffix-lens
base-suffix-lens-id
#:with [(~var clause (clause #'base-suffix #'base-suffix-lens)) ...]
#'[unchecked-clause ...]
#:with def
(with-sub-range-binders
#'(begin
(define base-suffix-lens
(lens-thrush base-lens suffix-lens-expr))
clause.def
...)
base-suffix-lens-sub-range)])
(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
(define-nested-lenses [first first-lens]
[first first-lens]
[second second-lens]
[third third-lens])
[third third-lens
[first first-lens]
[second second-lens]])
(check-equal? (lens-view first-first-lens '((a b c d) e)) 'a)
(check-equal? (lens-view first-second-lens '((a b c d) e)) 'b)
(check-equal? (lens-view first-third-lens '((a b c d) e)) 'c)
(check-equal? (lens-view first-third-first-lens '((a b (c d) e) f)) 'c)
(check-equal? (lens-view first-third-second-lens '((a b (c d) e) f)) 'd)

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

@ -5,7 +5,9 @@
@title{Lenses for nested data}
@defform[(define-nested-lenses [base-id base-lens-expr] clause ...)
#:grammar ([clause [sub-id sub-lens-expr]])]{
#:grammar ([clause [sub-id sub-lens-expr
clause
...]])]{
A shorthand for defining composed lenses for nested data structures.
For example, if there is a @racket[top] struct containing a
@ -19,16 +21,27 @@ Will define @racket[top-middle-x-lens] and @racket[top-middle-y-lens]
as @racket[(lens-thrush top-middle-lens middle-x-lens)] and
@racket[(lens-thrush top-middle-lens middle-y-lens)].
Clauses can be nested within other clauses as well:
@lens-unstable-examples[
(struct/lens ball (mass position velocity) #:transparent)
(struct/lens game (player1 player2) #:transparent)
(struct/lens player (position score) #:transparent)
(struct/lens position (x y) #:transparent)
(struct/lens velocity (x y) #:transparent)
(define-nested-lenses [ball-pos ball-position-lens]
[x position-x-lens]
[y position-y-lens])
(define-nested-lenses [ball-vel ball-velocity-lens]
[x velocity-x-lens]
[y velocity-y-lens])
(lens-view ball-vel-x-lens (ball 1 (position 2 3) (velocity 4 5)))
(lens-set ball-vel-x-lens (ball 1 (position 2 3) (velocity 4 5)) 1004)
(define-nested-lenses [game-player1 game-player1-lens]
[score player-score-lens]
[position player-position-lens
[x position-x-lens]
[y position-y-lens]])
(define-nested-lenses [game-player2 game-player2-lens]
[score player-score-lens]
[position player-position-lens
[x position-x-lens]
[y position-y-lens]])
(define the-game (game (player (position 1 2) 5) (player (position 3 4) 6)))
(lens-view game-player1-score-lens the-game)
(lens-view game-player1-position-lens the-game)
(lens-view game-player1-position-x-lens the-game)
(lens-set game-player1-score-lens the-game 9005)
(lens-set game-player1-position-lens the-game (position 2 0))
(lens-set game-player1-position-x-lens the-game 3)
]}

23
unstable/lens/private/id-append.rkt
View File

@ -2,7 +2,8 @@
(provide id-append)
(require racket/syntax
(require racket/list
racket/syntax
syntax/srcloc)
;; orig : Syntax -> Syntax
@ -28,8 +29,26 @@
(define (empty-id ctxt)
(datum->syntax ctxt '||))
(define appended-id-prop (gensym 'appended-id))
;; id-append : #:context Syntax Identifier ... -> (values Identifier Sub-Range-Binder-Prop)
;; a wrapper around id-append* that keeps track of identifiers that
;; are themselves appended from other identifiers
(define (id-append #:context ctxt . ids)
(define ids*
(append*
(for/list ([id (in-list ids)])
;; appended : (U #false (Listof Id))
(define appended (syntax-property id appended-id-prop))
(cond [appended appended]
[else (list id)]))))
(define-values [id sub-range-binders]
(apply id-append* #:context ctxt ids*))
(values (syntax-property id appended-id-prop ids*)
sub-range-binders))
;; id-append* : #:context Syntax Identifier ... -> (values Identifier Sub-Range-Binder-Prop)
(define (id-append* #:context ctxt . ids)
;; binder-procs : (Listof Binder-Proc)
(define-values [id n binder-procs]
(for/fold ([id1 (empty-id ctxt)] [n 0] [binder-procs '()])
@ -40,5 +59,7 @@
(define id* (orig id))
(values id*
(get-sub-range-binders id* binder-procs)))