Merge pull request #179 from AlexKnauth/lens-join-struct

add lens-join/struct

info.rkt

@@ -14,6 +14,7 @@
     "fancy-app"
     "alexis-util"
     "sweet-exp"
+    "kw-make-struct"
     "scribble-lib"))
 
 

lens/private/test-util/test-multi.rkt

@@ -0,0 +1,21 @@
+#lang sweet-exp racket/base
+
+provide test-multi*
+
+require racket/match
+        racket/string
+        racket/format
+        syntax/parse/define
+        rackunit
+        for-syntax racket/base
+                   syntax/parse
+
+(define-simple-macro
+  (test-multi* ([test-id:id #:in [test-variant:expr ...]] ...)
+    body ...)
+  #:with [pair-id ...] (generate-temporaries #'[test-id ...])
+  #:with [which-test ...] (generate-temporaries #'[test-id ...])
+  (for* ([pair-id (in-list (list (cons 'test-variant test-variant) ...))] ...)
+    (match-define (cons which-test test-id) pair-id) ...
+    (test-case (string-join (list (format "~a = ~a" 'test-id which-test) ...) ", ")
+      body ...)))

unstable/lens/main.rkt

@@ -10,6 +10,7 @@
          "string-split.rkt"
          "match.rkt"
          "set-filterer.rkt"
+         "struct-join.rkt"
          )
 
 (provide (all-from-out "syntax.rkt"
@@ -22,4 +23,5 @@
                        "string-split.rkt"
                        "match.rkt"
                        "set-filterer.rkt"
+                       "struct-join.rkt"
                        ))

unstable/lens/main.scrbl

@@ -19,3 +19,4 @@ this library being backwards-compatible.
 @include-section["string-split.scrbl"]
 @include-section["match.scrbl"]
 @include-section["set-filterer.scrbl"]
+@include-section["struct-join.scrbl"]

unstable/lens/struct-join.rkt

@@ -0,0 +1,81 @@
+#lang sweet-exp racket/base
+
+provide lens-join/struct
+
+require racket/local
+        racket/match
+        lens/private/base/main
+        kw-make-struct
+        for-syntax racket/base
+                   syntax/parse
+module+ test
+  require rackunit lens/private/hash/main lens/private/test-util/test-multi
+
+(begin-for-syntax
+  (define-splicing-syntax-class field-lenses
+    #:attributes ([lens-expr 1] [lens-id 1] [vw-id 1] [norm 1])
+    [pattern (~seq lens-expr:expr ...)
+      #:with [lens-id ...] (generate-temporaries #'[lens-expr ...])
+      #:with [vw-id ...] (generate-temporaries #'[lens-expr ...])
+      #:with [norm ...] #'[vw-id ...]]
+    [pattern (~seq fst-lens:expr ...+ rst:field-lenses)
+      #:with [fst-lens-id ...] (generate-temporaries #'[fst-lens ...])
+      #:with [fst-vw-id ...] (generate-temporaries #'[fst-lens ...])
+      #:with [lens-expr ...] #'[fst-lens ... rst.lens-expr ...]
+      #:with [lens-id ...] #'[fst-lens-id ... rst.lens-id ...]
+      #:with [vw-id ...] #'[fst-vw-id ... rst.vw-id ...]
+      #:with [norm ...] #'[fst-vw-id ... rst.norm ...]]
+    [pattern (~seq (~seq kw:keyword fst-lens:expr) ...+ rst:field-lenses)
+      #:with [fst-lens-id ...] (generate-temporaries #'[fst-lens ...])
+      #:with [fst-vw-id ...] (generate-temporaries #'[fst-lens ...])
+      #:with [lens-expr ...] #'[fst-lens ... rst.lens-expr ...]
+      #:with [lens-id ...] #'[fst-lens-id ... rst.lens-id ...]
+      #:with [vw-id ...] #'[fst-vw-id ... rst.vw-id ...]
+      #:with [[fst-kw/vw-id ...] ...] #'[[kw fst-vw-id] ...]
+      #:with [norm ...] #'[fst-kw/vw-id ... ... rst.norm ...]]
+    ))
+
+(define-syntax lens-join/struct
+  (lambda (stx)
+    (syntax-parse stx
+      [(lens-join/struct s:id flds:field-lenses)
+       #:with make/kw-form #`(make/kw/derived #,stx s flds.norm ...)
+       #:with [[lens-id/vw-id ...] ...] #'[[flds.lens-id flds.vw-id] ...]
+       #`(local [(define flds.lens-id flds.lens-expr) ...]
+           (make-lens
+            (λ (tgt)
+              (define flds.vw-id (lens-view flds.lens-id tgt))
+              ...
+              make/kw-form)
+            (λ (tgt nvw)
+              (match-define make/kw-form nvw)
+              (lens-set/list tgt lens-id/vw-id ... ...))))])))
+
+(module+ test
+  (struct foo (a b c) #:transparent)
+  (define foo-hash-lens1
+    (lens-join/struct foo
+                      (hash-ref-lens 'a)
+                      (hash-ref-lens 'b)
+                      (hash-ref-lens 'c)))
+  (define foo-hash-lens2
+    (lens-join/struct foo
+                      #:a (hash-ref-lens 'a)
+                      #:b (hash-ref-lens 'b)
+                      #:c (hash-ref-lens 'c)))
+  (define foo-hash-lens3
+    (lens-join/struct foo
+                      #:c (hash-ref-lens 'c)
+                      #:a (hash-ref-lens 'a)
+                      #:b (hash-ref-lens 'b)))
+  (define foo-hash-lens4
+    (lens-join/struct foo
+                      (hash-ref-lens 'a)
+                      #:c (hash-ref-lens 'c)
+                      #:b (hash-ref-lens 'b)))
+  (test-multi* ([foo-hash-lens #:in [foo-hash-lens1 foo-hash-lens2 foo-hash-lens3 foo-hash-lens4]])
+    (check-equal? (lens-view foo-hash-lens (hash 'a 1 'b 2 'c 3))
+                  (foo 1 2 3))
+    (check-equal? (lens-set foo-hash-lens (hash 'a 1 'b 2 'c 3) (foo 10 20 30))
+                  (hash 'a 10 'b 20 'c 30))
+    ))

unstable/lens/struct-join.scrbl

@@ -0,0 +1,30 @@
+#lang scribble/manual
+
+@(require lens/private/doc-util/main)
+
+@title{Joining lenses with structs}
+
+@defmodule[unstable/lens/struct-join]
+
+@defform[(lens-join/struct struct-id field-lens ...)
+         #:grammar ([field-lens (code:line lens-expr)
+                                (code:line field-keyword lens-expr)])]{
+Like @racket[lens-join/list], except that the views of the given
+lenses are put in an instance of the @racket[struct-id] struct instead
+of in a list. 
+@lenses-unstable-examples[
+  (struct foo (a b) #:transparent)
+  (define lens (lens-join/struct foo first-lens third-lens))
+  (lens-view lens '(1 2 3))
+  (lens-set lens '(1 2 3) (foo 'a 'b))
+]
+Struct fields in a @racket[lens-join/struct] form can also be
+specified by keywords, in any order, and even with some fields specied
+by position and some by keywords:
+@lenses-unstable-examples[
+  (struct foo (a b) #:transparent)
+  (lens-view (lens-join/struct foo first-lens third-lens) '(1 2 3))
+  (lens-view (lens-join/struct foo #:a first-lens #:b third-lens) '(1 2 3))
+  (lens-view (lens-join/struct foo #:b third-lens #:a first-lens) '(1 2 3))
+  (lens-view (lens-join/struct foo first-lens #:b third-lens) '(1 2 3))
+]}