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

allow define-nested-lenses clauses to contain other clauses

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)
+  (define-syntax-class (clause base-id base-lens-tmp)
-    [pattern [suffix-id:id suffix-lens-expr:expr]
+    #:attributes (def)
-             #:do [(define-values [base-suffix-lens-id sub-range-binders]
+    [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))]
+                                base-id -- #'suffix-id))
-             #:with [base-suffix-lens ...]
+                   (define-values [base-suffix-lens-id base-suffix-lens-sub-range]
-             (list base-suffix-lens-id)
+                     (id-append #:context base-id
-             #:with [suffix-lens ...]
+                                base-suffix-id -lens))]
-             (list #'suffix-lens-expr)
+             #:with base-suffix
-             #:attr sub-range-binders
+             base-suffix-id
-             sub-range-binders])
+             #: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)
 

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 [game-player1 game-player1-lens]
-  (define-nested-lenses [ball-pos ball-position-lens]
+    [score player-score-lens]
+    [position player-position-lens
       [x position-x-lens]
-    [y position-y-lens])
+      [y position-y-lens]])
-  (define-nested-lenses [ball-vel ball-velocity-lens]
+  (define-nested-lenses [game-player2 game-player2-lens]
-    [x velocity-x-lens]
+    [score player-score-lens]
-    [y velocity-y-lens])
+    [position player-position-lens
-  (lens-view ball-vel-x-lens (ball 1 (position 2 3) (velocity 4 5)))
+      [x position-x-lens]
-  (lens-set ball-vel-x-lens (ball 1 (position 2 3) (velocity 4 5)) 1004)
+      [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)
 ]}

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 '()])
@@ -42,3 +61,5 @@
           (get-sub-range-binders id* binder-procs)))
 
 
+      
+