diff --git a/unstable/lens/define-nested.rkt b/unstable/lens/define-nested.rkt index 47002e8..1d810bc 100644 --- a/unstable/lens/define-nested.rkt +++ b/unstable/lens/define-nested.rkt @@ -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) diff --git a/unstable/lens/define-nested.scrbl b/unstable/lens/define-nested.scrbl index 1e2a9f0..1ae7dc6 100644 --- a/unstable/lens/define-nested.scrbl +++ b/unstable/lens/define-nested.scrbl @@ -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) ]} diff --git a/unstable/lens/private/id-append.rkt b/unstable/lens/private/id-append.rkt index 7601a3c..ce5c8b9 100644 --- a/unstable/lens/private/id-append.rkt +++ b/unstable/lens/private/id-append.rkt @@ -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))) + +