Merge pull request #243 from AlexKnauth/nested-lens-macro

add define-nested-lenses

unstable/lens/define-nested.rkt

@@ -0,0 +1,68 @@
+#lang sweet-exp racket/base
+
+provide define-nested-lenses
+
+require lens/private/compound/thrush
+        for-syntax racket/base
+                   racket/syntax
+                   syntax/parse
+                   syntax/srcloc
+                   "private/id-append.rkt"
+module+ test
+  require lens/private/base/base
+          lens/private/list/main
+          rackunit
+
+begin-for-syntax
+  (define (with-sub-range-binders stx prop)
+    (syntax-property stx 'sub-range-binders prop))
+  (define -- (update-source-location (datum->syntax #f '-)
+                                    #:span 1))
+  (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]
+                     (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])
+
+
+(define-syntax define-nested-lenses
+  (syntax-parser
+    [(define-nested-lenses [base:id base-lens-expr:expr]
+       (~var clause (clause #'base))
+       ...)
+     #: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
+         ...)]))
+
+module+ test
+  (define-nested-lenses [first first-lens]
+    [first first-lens]
+    [second second-lens]
+    [third third-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)
+

unstable/lens/define-nested.scrbl

@@ -0,0 +1,36 @@
+#lang scribble/manual
+
+@(require lens/private/doc-util/main)
+
+@title{Lenses for nested data}
+
+@defmodule[unstable/lens/define-nested]
+
+@defform[(define-nested-lenses [base-id base-lens-expr] clause ...)
+         #:grammar ([clause [sub-id sub-lens-expr]])]{
+A shorthand for defining composed lenses for nested data structures.
+
+For example, if there is a @racket[top] struct containing a
+@racket[middle] struct, which contains an @racket[x] field and a
+@racket[y] field, a form like:
+@(racketblock
+  (define-nested-lenses [top-middle top-middle-lens]
+    [x middle-x-lens]
+    [y middle-y-lens]))
+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)].
+
+@lens-unstable-examples[
+  (struct/lens ball (mass position velocity) #: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)
+]}

unstable/lens/main.rkt

@@ -1,5 +1,6 @@
 #lang reprovide
 "arrow.rkt"
+"define-nested.rkt"
 "dict-nested.rkt"
 "hash-filterer.rkt"
 "if.rkt"

unstable/lens/main.scrbl

@@ -13,6 +13,7 @@ this library being backwards-compatible.
 
 @(include-sections
   "arrow.scrbl"
+  "define-nested.scrbl"
   "dict-nested.scrbl"
   "hash-filterer.scrbl"
   "if.scrbl"

unstable/lens/private/id-append.rkt

@@ -0,0 +1,44 @@
+#lang racket/base
+
+(provide id-append)
+
+(require racket/syntax
+         syntax/srcloc)
+
+;; orig : Syntax -> Syntax
+(define (orig stx)
+  (syntax-property stx 'original-for-check-syntax #t))
+
+;; Sub-Range-Binder-Prop = (Treeof (Vector Id Nat Nat Real Real Id Nat Nat Real Real))
+;; Binder-Proc = Id -> Sub-Range-Binder-Prop
+
+;; make-binder-proc : Id Nat -> Binder-Proc
+(define ((make-binder-proc base n) id)
+  (vector (syntax-local-introduce id)
+          n (syntax-span base) 0.5 0.5
+          (syntax-local-introduce base)
+          0 (syntax-span base) 0.5 0.5))
+
+;; get-sub-range-binders : Id (Listof Binder-Proc) -> Sub-Range-Binder-Prop
+(define (get-sub-range-binders id binder-procs)
+  (for/list ([binder-proc (in-list binder-procs)])
+    (binder-proc id)))
+
+;; empty-id : Syntax -> Id
+(define (empty-id ctxt)
+  (datum->syntax ctxt '||))
+
+;; 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 '()])
+              ([id2 (in-list ids)])
+      (values (format-id ctxt "~a~a" id1 id2)
+              (+ n (syntax-span id2))
+              (cons (make-binder-proc id2 n) binder-procs))))
+  (define id* (orig id))
+  (values id*
+          (get-sub-range-binders id* binder-procs)))
+      
+