Add struct-nested-lens

lens/doc-util/lenses-examples.rkt

@@ -2,9 +2,11 @@
 
 (provide lenses-examples
          lenses-applicable-examples
-         lenses-unstable-examples)
+         lenses-unstable-examples
+         define-persistant-lenses-unstable-examples)
 
-(require scribble/eval)
+(require scribble/eval
+         racket/splicing)
 
 
 (define-syntax-rule (define-examples-form id require-spec ...)
@@ -16,6 +18,17 @@
     (define-syntax-rule (id datum (... ...))
       (examples #:eval (eval-factory) datum (... ...)))))
 
+(define-syntax-rule (define-examples/persistance-syntax id require-spec ...)
+  (begin
+    (define (eval-factory)
+      (define base-eval (make-base-eval))
+      (base-eval '(require require-spec)) ...
+      base-eval)
+    (define-syntax-rule (id examples-id)
+      (begin
+        (splicing-let ([the-eval (eval-factory)])
+          (define-syntax-rule (examples-id datum (... (... ...)))
+            (examples #:eval the-eval datum (... (... ...)))))))))
 
 (define-examples-form lenses-examples
   lens racket/list racket/vector racket/stream)
@@ -25,3 +38,6 @@
 
 (define-examples-form lenses-unstable-examples
   lens unstable/lens racket/list racket/vector racket/stream)
+
+(define-examples/persistance-syntax define-persistant-lenses-unstable-examples
+  lens unstable/lens racket/list racket/vector racket/stream)

unstable/lens/main.rkt

@@ -2,6 +2,7 @@
 
 (require "syntax.rkt"
          "view-set.rkt"
+         "struct-nested.rkt"
          "sublist.rkt"
          "arrow.rkt"
          "isomorphism.rkt"
@@ -12,6 +13,7 @@
 
 (provide (all-from-out "syntax.rkt"
                        "view-set.rkt"
+                       "struct-nested.rkt"
                        "sublist.rkt"
                        "arrow.rkt"
                        "isomorphism.rkt"

unstable/lens/main.scrbl

@@ -11,6 +11,7 @@ this library being backwards-compatible.
 
 @include-section["view-set.scrbl"]
 @include-section["syntax.scrbl"]
+@include-section["struct-nested.scrbl"]
 @include-section["sublist.scrbl"]
 @include-section["arrow.scrbl"]
 @include-section["isomorphism.scrbl"]

unstable/lens/struct-nested.rkt

@@ -0,0 +1,34 @@
+#lang racket/base
+
+(require fancy-app
+         lens
+         (for-syntax racket/base
+                     syntax/parse))
+
+(module+ test
+  (require rackunit))
+
+(provide struct-nested-lens)
+
+
+(define-syntax struct-nested-lens
+  (syntax-parser
+    [(_ struct-id:id field-id:id)
+     #'(struct-lens struct-id field-id)]
+    [(_ struct-id:id [field-id:id field-struct-id:id] rest ...)
+     #'(lens-thrush (struct-lens struct-id field-id)
+                    (struct-nested-lens field-struct-id rest ...))]
+    [(_ struct-id:id field-and-field-struct-id:id rest ...)
+     #'(struct-nested-lens struct-id
+                           [field-and-field-struct-id field-and-field-struct-id]
+                           rest ...)]))
+
+(module+ test
+  (struct a (b b2) #:prefab)
+  (struct b (b1 b2 b3) #:prefab)
+  (define a-b-b1-lens (struct-nested-lens a b b1))
+  (define a-b2-b3-lens (struct-nested-lens a [b2 b] b3))
+  (check-equal? (lens-view a-b-b1-lens (a (b 1 2 3) 'foo)) 1)
+  (check-equal? (lens-set a-b-b1-lens (a (b 1 2 3) 'foo) 10) (a (b 10 2 3) 'foo))
+  (check-equal? (lens-view a-b2-b3-lens (a 'foo (b 1 2 3))) 3)
+  (check-equal? (lens-set a-b2-b3-lens (a 'foo (b 1 2 3)) 10) (a 'foo (b 1 2 10))))

unstable/lens/struct-nested.scrbl

@@ -0,0 +1,50 @@
+#lang scribble/manual
+
+@(require lens/doc-util/main)
+
+@title{Nested struct lenses}
+
+@defmodule[unstable/lens/struct-nested]
+
+@(define-persistant-lenses-unstable-examples struct-nested-examples)
+
+@defform[#:id struct-nested-lens
+         (struct-nested-lens struct-id intermediate ... field-id)
+         #:grammar ([intermediate (code:line [subfield-id subfield-struct-id]) both-id])]{
+  Constructs a lens that views nested structures. The first @racket[struct-id] is the
+  outermost struct type, the last @racket[field-id] is the innermost target field. Each
+  @racket[intermediate] specifies how to walk down one level of the nested structs, and
+  is either a pair of a @racket[subfield-id] and that field's struct type in
+  @racket[subfield-struct-id], or a single @racket[both-id] in the common case that the
+  field name is the same as the struct name.
+
+  For example, given a complicated nested tree of state representing a game:
+  @struct-nested-examples[
+    (struct game (player level) #:transparent)
+    (struct player (posn stats) #:transparent)
+    (struct posn (x y) #:transparent)
+    (struct combat-stats (health attack) #:transparent)
+    (define the-game (game (player (posn 0 0) (combat-stats 10 1)) 'foo-level))
+    the-game
+  ]
+
+  We can create a lens for traversing the nested structures of the game state.
+  This takes advantage of the fact that each struct's fields are the same name
+  as the struct that that field is a value of.
+  @struct-nested-examples[
+    (define game-player-posn-x-lens
+      (struct-nested-lens game player posn x))
+    (lens-view game-player-posn-x-lens the-game)
+    (lens-set game-player-posn-x-lens the-game 3)
+  ]
+
+  In the case of the player's combat stats, the field is @italic{not} the
+  same name as the @racket[combat-stats] struct. Therefore, we use the
+  more verbose @racket[[subfield-id subfield-struct-id]] form for that
+  step of the nested struct traversal.
+  @struct-nested-examples[
+    (define game-player-health-lens
+      (struct-nested-lens game player [stats combat-stats] health))
+    (lens-view game-player-health-lens the-game)
+    (lens-set game-player-health-lens the-game 20)
+]}