Merge pull request #5 from AlexKnauth/struct2

Allow applicable lenses

.gitignore

@@ -3,3 +3,4 @@
 **/*.html
 **/*.css
 **/*.js
+*~

lenses/applicable.rkt

@@ -0,0 +1,42 @@
+#lang racket/base
+
+(provide (all-defined-out)
+         lens/c let-lens lens-view lens-set lens-transform lens-struct lens-proc)
+
+(require (prefix-in - "main.rkt")
+         (only-in "main.rkt"
+                  lens/c let-lens lens-view lens-set lens-transform lens-struct lens-proc))
+
+(define (make-lens getter setter)
+  (lens-struct (-make-lens getter setter)))
+
+(define (lens-compose . args)
+  (lens-struct (apply -lens-compose args)))
+
+(define identity-lens
+  (lens-struct -identity-lens))
+
+(define (list-lens n)
+  (lens-struct (-list-lens n)))
+
+(define first-lens (lens-struct -first-lens))
+(define second-lens (lens-struct -second-lens))
+(define third-lens (lens-struct -third-lens))
+(define fourth-lens (lens-struct -fourth-lens))
+(define fifth-lens (lens-struct -fifth-lens))
+
+(define (assoc-lens key #:is-equal? [key-equal? equal?])
+  (lens-struct (-assoc-lens key #:is-equal? key-equal?)))
+
+(define (assv-lens key)
+  (lens-struct (-assv-lens key)))
+
+(define (assq-lens key)
+  (lens-struct (-assq-lens key)))
+
+(define-syntax-rule (syntax-lens target-id pattern)
+  (lens-struct (-syntax-lens target-id pattern)))
+
+(define-syntax-rule (syntax-keyword-seq-lens kw)
+  (lens-struct (-syntax-keyword-seq-lens kw)))
+

lenses/core.rkt

@@ -1,6 +1,6 @@
 #lang racket
 
-(require fancy-app)
+(require fancy-app unstable/contract)
 
 (provide lens/c
          make-lens
@@ -8,26 +8,59 @@
          lens-view
          lens-set
          lens-transform
-         lens-compose)
+         lens-compose
+         identity-lens
+         lens-struct
+         lens-proc
+         )
 
 (module+ test
   (require rackunit))
 
 
-(define (lens/c input subcomponent)
+(define (lens-proc/c input subcomponent)
   (-> input
       (values subcomponent
               (-> subcomponent
                   input))))
 
+(define lens-2-val-context-key
+  (make-continuation-mark-key 'lens-2-val-context-key))
+
+(define-syntax-rule (let/immediate-mark key-expr val-id body-expr ...)
+  (call-with-immediate-continuation-mark key-expr (lambda (val-id) body-expr ...)))
+
+(struct lens-struct (proc)
+  #:property prop:procedure
+  (lambda (this target)
+    (let/immediate-mark lens-2-val-context-key lens-2-val-context?
+      (if lens-2-val-context?
+          ((lens-struct-proc this) target)
+          (lens-view (lens-struct-proc this) target)))))
+
+(define (lens-proc lns)
+  (match lns
+    [(lens-struct proc) proc]
+    [(? procedure?  proc) proc]))
+
+(define (lens/c target/c view/c)
+  (define proc/c (lens-proc/c target/c view/c))
+  (if/c lens-struct?
+        (struct/c lens-struct proc/c)
+        proc/c))
+
 (module+ test
-  (define list-lens (lens/c list? any/c))
-  (check-pred chaperone-contract? list-lens))
+  (define list-lens/c (lens/c list? any/c))
+  (check-true (contract? list-lens/c))
+  (check-false (flat-contract? list-lens/c)))
 
 
 (define ((make-lens getter setter) v)
   (values (getter v)
-          (setter v _)))
+          (setter v _))) ; fancy-app
+
+(define identity-lens
+  (values _ identity)) ; fancy-app
 
 (module+ test
   (define (set-first l v)
@@ -35,11 +68,20 @@
   (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)))
+  (check-equal? (lens-set first-lens test-list 'a) '(a 2 3))
+  (check-equal? (lens-view identity-lens 3) 3)
+  (check-equal? (lens-set identity-lens 3 4) 4)
+  (check-equal? (lens-compose) identity-lens)
+  (define first* (lens-struct first-lens))
+  (check-equal? (first* test-list) 1)
+  (check-equal? (lens-view first* test-list) 1)
+  (check-equal? (lens-set first* test-list 'a) '(a 2 3))
+  )
 
 
 (define-syntax-rule (let-lens (view setter) lens-call-expr body ...)
-  (let-values ([(view setter) lens-call-expr])
+  (let-values ([(view setter) (with-continuation-mark lens-2-val-context-key #t
+                                lens-call-expr)])
     body ...))
 
 (module+ test
@@ -79,7 +121,7 @@
   (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 first-of-second-lens (lens-compose 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)
@@ -99,4 +141,11 @@
   (check-eqv? (num-append 1) 1))
 
 
-(define lens-compose (generalize-operator lens-compose2))
+(define lens-compose-proc (generalize-operator lens-compose2))
+
+(define lens-compose
+  (case-lambda
+    [() identity-lens]
+    [(v . vs)
+     (apply lens-compose-proc v vs)]))
+

lenses/lenses.scrbl

@@ -27,7 +27,8 @@ source code: @url["https://github.com/jackfirth/lenses"]
 @section{Core Lens Forms}
 
 @defproc[(lens/c [target/c contract?] [view/c contract?]) contract?]{
-  Contract constructor for lenses. A lens is a function that takes one
+  Contract constructor for lenses. A lens is either a function or
+  @racket[lens-struct] containing that function. The function takes one
   value, its @italic{target}, and returns two values, a @italic{view}
   and a @italic{context}. The context is a function that takes a new view
   value and "replaces" the old view value with the new value, giving a
@@ -35,8 +36,8 @@ source code: @url["https://github.com/jackfirth/lenses"]
   specific piece of a @racket[target/c] that is a @racket[view/c],
   along with a way to replace that piece with a new view value. Lenses
   deconstruct and reconstruct data by examinimg small portions of their
-  structure. In terms of contracts, a @racket[(lens/c target/c view/c)]
-  is equivalent to the following function contract:
+  structure. In terms of contracts, @racket[(lens/c target/c view/c)]
+  checks the function with following function contract:
   @racketblock[
     (-> target/c
         (values view/c
@@ -46,10 +47,23 @@ source code: @url["https://github.com/jackfirth/lenses"]
   An example is the @racket[first-lens], which is a lens for examiniming
   specifically the first item in a list:
   @lenses-examples[
-    (first-lens '(1 2 3))
-    (let-values ([(_ context) (first-lens '(1 2 3))])
+    (define first-lens-proc (lens-proc first-lens))
+    (first-lens-proc '(1 2 3))
+    (let-values ([(_ context) (first-lens-proc '(1 2 3))])
       (context 'a))
-]}
+    (let-lens (_ context) (first-lens '(1 2 3))
+      (context 'a))
+  ]
+
+  Lenses that are instances of the lens struct can also be used directly
+  as getter procedures:
+  @lenses-examples[
+    (define first-lens* (lens-struct first-lens))
+    (first-lens* '(1 2 3))
+    (let-lens (fst context) (first-lens* '(1 2 3))
+      (values fst (context 'a)))
+  ]
+}
 
 @defproc[(make-lens [getter (-> target/c view/c)]
                     [setter (-> target/c view/c target/c)])
@@ -66,9 +80,8 @@ source code: @url["https://github.com/jackfirth/lenses"]
 ]}
 
 @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
-  clarity and to eliminate a few extra parens.
+  Gets the two return values of a lens function and binds them to the
+  given identifiers within the body expressions.
   @lenses-examples[
     (let-lens (view context) (first-lens '(1 2 3))
       (printf "View is ~a\n" view)
@@ -105,7 +118,7 @@ source code: @url["https://github.com/jackfirth/lenses"]
     (lens-transform first-lens number->string '(1 2 3))
 ]}
 
-@defproc[(lens-compose [lens proc] ...+) proc?]{
+@defproc[(lens-compose [lens proc] ...) lens?]{
   Composes the given lenses together into one @italic{compound lens}.
   The compound lens operates similarly to composed functions do in
   that the last @racket[lens] is the first @racket[lens] the compound
@@ -117,6 +130,10 @@ source code: @url["https://github.com/jackfirth/lenses"]
     (lens-set first-of-second-lens '((1 a) (2 b) (3 c)) 200)
 ]}
 
+@defthing[identity-lens (lens/c any/c any/c)]{
+The identity lens.
+}
+
 @section{List lenses}
 
 @defproc[(list-lens [n exact-nonnegative-integer?])
@@ -222,3 +239,24 @@ source code: @url["https://github.com/jackfirth/lenses"]
     (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))
 ]}
+
+@section{Lens Structs}
+
+@defproc[(lens-struct [proc procedure?]) lens-struct?]{
+Wraps a lens function in the lens struct. The result lens can also be
+used directly as a getter procedure.
+}
+
+@defproc[(lens-proc [lens lens?]) procedure?]{
+Gets a lens function. If @racket[lens] is a lens function but not a lens
+struct, returns the @racket[lens].
+}
+
+@section{lenses/applicable}
+
+@defmodule[lenses/applicable]
+
+This module provides the same functions as @racketmodname[lenses], but lenses
+are provided as applicable lens structs, and functions that return lenses return
+lens structs.
+