Add make-lens and keyword stx lens

info.rkt

@@ -1,8 +1,17 @@
 #lang info
 
 (define collection 'multi)
-(define deps '("base" "rackunit-lib"))
-(define build-deps '("cover"
-                     "scribble-lib"
-                     "rackunit-lib"
-                     "racket-doc"))
+
+
+(define deps
+  '("base"
+    "rackunit-lib"
+    "fancy-app"
+    "mischief"))
+
+
+(define build-deps
+  '("cover"
+    "scribble-lib"
+    "rackunit-lib"
+    "racket-doc"))

lenses/core.rkt

@@ -1,8 +1,9 @@
 #lang racket
 
-(require rackunit)
+(require fancy-app)
 
 (provide lens/c
+         make-lens
          let-lens
          lens-view
          lens-set
@@ -10,17 +11,8 @@
          lens-compose)
 
 (module+ test
-  (define (first-lens lst)
-    (values (first lst)
-            (λ (v) (cons v (drop lst 1)))))
-  (define (second-lens lst)
-    (values (second lst)
-            (λ (v)
-              (append (take lst 1)
-                      (list v)
-                      (drop lst 2))))))
+  (require rackunit))
 
-;; Lens contract
 
 (define (lens/c input subcomponent)
   (-> input
@@ -32,7 +24,19 @@
   (define list-lens (lens/c list? any/c))
   (check-pred chaperone-contract? list-lens))
 
-;; Lens result local bindings syntax
+
+(define ((make-lens getter setter) v)
+  (values (getter v)
+          (setter v _)))
+
+(module+ test
+  (define (set-first l v)
+    (list* v (rest l)))
+  (define test-list '(1 2 3))
+  (define first-lens (make-lens first set-first))
+  (check-equal? (lens-view first-lens test-list) 1)
+  (check-equal? (lens-set first-lens test-list 'a) '(a 2 3)))
+
 
 (define-syntax-rule (let-lens (view setter) lens-call-expr body ...)
   (let-values ([(view setter) lens-call-expr])
@@ -43,7 +47,6 @@
     (check-eqv? view-first 1)
     (check-equal? (setter-first 'a) '(a 2 3 4 5))))
 
-;; Helpers for only working with one half of a lens
 
 (define (lens-view lens v)
   (let-lens (view _) (lens v)
@@ -54,19 +57,17 @@
     (setter x)))
 
 (module+ test
-  (check-eqv? (lens-view second-lens '(1 2 3)) 2)
-  (check-equal? (lens-set second-lens '(1 2 3) 'a) '(1 a 3)))
+  (check-eqv? (lens-view first-lens '(1 2 3)) 1)
+  (check-equal? (lens-set first-lens '(1 2 3) 'a) '(a 2 3)))
 
-;; Composing a lens with a function to make a value-sensitive setter
 
 (define (lens-transform lens f v)
   (let-lens (view setter) (lens v)
     (setter (f view))))
 
 (module+ test
-  (check-equal? (lens-transform second-lens number->string '(1 2 3)) '(1 "2" 3)))
+  (check-equal? (lens-transform first-lens number->string '(1 2 3)) '("1" 2 3)))
 
-;; Lens composition
 
 (define ((lens-compose2 sub-lens super-lens) v)
   (let-lens (super-view super-setter) (super-lens v)
@@ -75,12 +76,16 @@
               (compose super-setter sub-setter)))))
 
 (module+ test
+  (define (second-set l v)
+    (list* (first l) v (rest (rest l))))
+  (define second-lens (make-lens second second-set))
   (define first-of-second-lens (lens-compose2 first-lens second-lens))
   (define test-alist '((a 1) (b 2) (c 3)))
   (check-eq? (lens-view first-of-second-lens test-alist) 'b)
   (check-equal? (lens-set first-of-second-lens test-alist 'B)
                 '((a 1) (B 2) (c 3))))
 
+
 (define ((generalize-operator op) v . vs)
   (if (empty? vs)
       v
@@ -93,4 +98,5 @@
   (check-eqv? (num-append 1 2 3 4 5) 12345)
   (check-eqv? (num-append 1) 1))
 
-(define lens-compose (generalize-operator lens-compose2))
+
+(define lens-compose (generalize-operator lens-compose2))

lenses/lenses.scrbl

@@ -7,6 +7,7 @@
 
 @(define lenses-eval (make-base-eval))
 @(lenses-eval '(require "main.rkt"))
+@(lenses-eval '(require racket/list))
 @(define-syntax-rule (lenses-examples datum ...)
    (examples #:eval lenses-eval datum ...))
 
@@ -50,6 +51,20 @@ source code: @url["https://github.com/jackfirth/lenses"]
       (context 'a))
 ]}
 
+@defproc[(make-lens [getter (-> target/c view/c)]
+                    [setter (-> target/c view/c target/c)])
+         (lens/c target/c view/c)]{
+  Given a getter and a setter, constructs a lens. The setter must take
+  the new value to use second.
+  @lenses-examples[
+    (define (set-first lst v)
+      (list* v (rest lst)))
+    (set-first '(1 2 3) 'a)
+    (define first-lens (make-lens first set-first))
+    (lens-view first-lens '(1 2 3))
+    (lens-set first-lens '(1 2 3) 'a)
+]}
+
 @defform[(let-lens (view-id context-id) lens-call-expr body ...)]{
   Restricted form of @racket[let-values] specifically for working with
   the return values of a lens function. This is purely for semantic
@@ -182,4 +197,28 @@ source code: @url["https://github.com/jackfirth/lenses"]
     (lens-set first-of-second-stx-lens
               #'(define (f a) a)
               #'g)
-]}
+]}
+
+@defproc[(syntax-keyword-seq-lens [kw keyword?])
+         (lens/c syntax? syntax?)]{
+  Constructs a lens that examines a non-flat syntax object
+  and views a syntax object containing all the terms in the
+  target syntax that appear after @racket[kw] but before any
+  other keyword.
+  @lenses-examples[
+    (define foo-kw-seq-lens (syntax-keyword-seq-lens '#:foo))
+    (lens-view foo-kw-seq-lens #'(a #:foo c d #:bar f))
+    (lens-set foo-kw-seq-lens #'(a #:foo c d #:bar f) #'(1 2 3 4 5 6))
+  ]
+  
+  If the target syntax object has no occurence of @racket[kw],
+  or if the occurence of @racket[kw] is at the end of the syntax
+  object or immediately followed by another keyword, then viewing
+  produces the empty list syntax object @racket[#'()]. In the case
+  where @racket[kw] is not present, setting is a no-op.
+  @lenses-examples[
+    (lens-view foo-kw-seq-lens #'(a b f g))
+    (lens-view foo-kw-seq-lens #'(a #:foo #:bar f))
+    (lens-set foo-kw-seq-lens #'(a #:foo #:bar f) #'(1 2 3 4 5 6))
+    (lens-set foo-kw-seq-lens #'(a b f g) #'(these are ignored))
+]}

lenses/list.rkt

@@ -1,6 +1,6 @@
 #lang racket
 
-(require rackunit
+(require fancy-app
          "core.rkt")
 
 (provide list-lens
@@ -13,17 +13,25 @@
          assv-lens
          assq-lens)
 
-(define ((list-lens i) lst)
-  (define (list-set-first v)
-    (cons v (drop lst 1)))
-  (define (list-set-i v)
+(module+ test
+  (require rackunit))
+
+
+(define (list-set-first lst v)
+  (cons v (drop lst 1)))
+
+(define ((list-setter i) lst v)
     (append (take lst i)
             (list v)
             (drop lst (add1 i))))
-  (values (list-ref lst i)
-          (if (zero? i)
-              list-set-first
-              list-set-i)))
+
+(define (list-getter i)
+  (list-ref _ i))
+
+(define (list-lens i)
+  (make-lens (list-getter i)
+             (if (zero? i) list-set-first (list-setter i))))
+
 
 (define first-lens (list-lens 0))
 (define second-lens (list-lens 1))
@@ -43,6 +51,7 @@
   (check-equal? (lens-set fourth-lens '(1 2 3 4 5) 'a) '(1 2 3 a 5))
   (check-equal? (lens-set fifth-lens '(1 2 3 4 5) 'a) '(1 2 3 4 a)))
 
+
 (define (assoc-swap assoc-list old-assoc-pair new-assoc-pair #:is-equal? [equal? equal?])
   (define (swap-assoc-pair assoc-pair)
     (if (equal? assoc-pair old-assoc-pair)
@@ -62,6 +71,7 @@
   (check-equal? (assoc-swap assoc-list '(b 2) '(FOO BAR))
                 '((a 1) (FOO BAR) (c 3))))
 
+
 (define ((assoc-lens key #:is-equal? [equal? equal?]) assoc-list)
   (define assoc-pair (assoc key assoc-list equal?))
   (define (assoc-lens-set v)
@@ -86,6 +96,7 @@
   (check-equal? (lens-set assoc-foo-lens assoc-str 100)
                 '(("bar" 1) ("foo" 100) ("baz" 3))))
 
+
 (define (assv-lens assv-key)
   (assoc-lens assv-key #:is-equal? eqv?))
 
@@ -96,6 +107,7 @@
   (check-equal? (lens-set assv-2-lens assv-list 'FOO)
                 '((1 a) (2 FOO) (3 c))))
 
+
 (define (assq-lens assq-key)
   (assoc-lens assq-key #:is-equal? eq?))
 

lenses/main.rkt

@@ -1,10 +1,9 @@
 #lang racket
 
-(require "core.rkt"
-         "list.rkt"
-         "syntax.rkt")
+(require mischief)
 
-(provide
- (all-from-out "core.rkt"
-               "list.rkt"
-               "syntax.rkt"))
+(require/provide
+ "core.rkt"
+ "list.rkt"
+ "syntax.rkt"
+ "syntax-keyword.rkt")

lenses/syntax-keyword.rkt

@@ -0,0 +1,54 @@
+#lang racket
+
+(require "core.rkt"
+         fancy-app
+         syntax/parse)
+
+(provide syntax-keyword-seq-lens)
+
+
+(define-syntax-rule (syntax-parse/default-noop stx option-or-clause ...)
+  (syntax-parse stx
+    option-or-clause ...
+    [default #'default]))
+
+
+(define (syntax-keyword-seq-get keyword stx)
+  (syntax-parse/default-noop stx
+    [(a rest ...)
+     (if (eq? (syntax->datum #'a) keyword)
+         (syntax-get-until-keyword #'(rest ...))
+         (syntax-keyword-seq-get keyword #'(rest ...)))]))
+
+
+(define (syntax-get-until-keyword stx)
+  (syntax-parse/default-noop stx
+    [((~and before-kw (~not _:keyword)) ... a:keyword rest ...)
+     #'(before-kw ...)]))
+
+
+(define (syntax-keyword-seq-set keyword stx new-stx)
+  (syntax-parse/default-noop stx
+    [(a rest ...+)
+     (if (eq? (syntax->datum #'a) keyword)
+         (syntax-set-until-keyword keyword #'(rest ...) new-stx)
+         #`(a #,@(syntax-keyword-seq-set keyword #'(rest ...) new-stx)))]))
+
+
+(define (cons-stx v-stx vs-stx)
+  (syntax-parse vs-stx
+    [(v ...) #`(#,v-stx v ...)]))
+
+
+(define (syntax-set-until-keyword keyword-val stx new-stx)
+  (define new-stx-with-keyword (cons-stx keyword-val new-stx))
+  (syntax-parse stx
+    [((~and before-kw (~not _:keyword)) ... a:keyword rest ...)
+     #`(#,@(syntax->list new-stx-with-keyword) a rest ...)]
+    [other new-stx-with-keyword]))
+
+
+(define (syntax-keyword-seq-lens keyword)
+  (define getter (syntax-keyword-seq-get keyword _))
+  (define setter (syntax-keyword-seq-set keyword _ _))
+  (make-lens getter setter))

lenses/syntax.rkt

@@ -9,6 +9,7 @@
 
 (provide syntax-lens)
 
+
 (define-syntax syntax-lens
   (syntax-parser
     [(_ target-name:id template)
@@ -26,6 +27,7 @@
   (define stx2 (lens-set stx-lens stx #'FOO))
   (check-equal? (syntax->datum stx2) '(a b (1 2 FOO 4 5) c d e f)))
 
+
 (begin-for-syntax
   
   (define (target-stx target-id)