From 3008e9ca15101105c7b14bb573fc879551fd0942 Mon Sep 17 00:00:00 2001
From: AlexKnauth <alexander@knauth.org>
Date: Mon, 6 Jul 2015 16:04:19 -0400
Subject: [PATCH 1/2] add gen:lens

---
 lens/base/base.rkt      | 57 +++--------------------------------------
 lens/base/contract.rkt  | 41 +++++++++++++++++++++++++++++
 lens/base/gen-lens.rkt  | 47 +++++++++++++++++++++++++++++++++
 lens/base/make-lens.rkt | 30 ++++++++++++++++++++++
 lens/base/view-set.rkt  | 14 +++-------
 5 files changed, 125 insertions(+), 64 deletions(-)
 create mode 100644 lens/base/contract.rkt
 create mode 100644 lens/base/gen-lens.rkt
 create mode 100644 lens/base/make-lens.rkt

diff --git a/lens/base/base.rkt b/lens/base/base.rkt
index 17eaec7..179ea96 100644
--- a/lens/base/base.rkt
+++ b/lens/base/base.rkt
@@ -1,57 +1,8 @@
-#lang racket
-
-(require fancy-app)
-
-(module+ test
-  (require rackunit))
-
-(provide let-lens
-         (contract-out [make-lens (-> (-> any/c any/c)
-                                      (-> any/c any/c any/c)
-                                      lens?)]
-                       [focus-lens (-> lens? any/c
-                                       (values any/c (-> any/c any/c)))]
-                       [use-applicable-lenses! (-> void?)]
-                       [lens? predicate/c]
-                       [lens/c (contract? contract? . -> . contract?)]
-                       ))
-
-
-(define lenses-applicable? (make-parameter #f))
-
-(define (use-applicable-lenses!)
-  (lenses-applicable? #t))
-
-(struct lens-struct (get set)
-  #:property prop:procedure
-  (lambda (this target)
-    (if (lenses-applicable?)
-        ((lens-struct-get this) target)
-        (error "cannot apply a non-applicable lens as a function"))))
-
-(define (lens/c target/c view/c)
-  (struct/c lens-struct (-> target/c view/c) (-> target/c view/c target/c)))
-
-(module+ test
-  (require rackunit)
-  (check-exn exn:fail? (thunk (first-lens '(a b c)))))
-
-(define lens? lens-struct?)
-
-(define (make-lens getter setter)
-  (lens-struct getter setter))
-
-(define (focus-lens lens target)
-  (match-define (lens-struct get set) lens)
-  (values (get target)
-          (set target _)))
-
-
-(define-syntax-rule (let-lens (view setter) lens-expr target-expr body ...)
-  (let-values ([(view setter) (focus-lens lens-expr target-expr)])
-    body ...))
-
+#lang racket/base
+(require (except-in "gen-lens.rkt" gen-lens/c) "make-lens.rkt" "contract.rkt")
+(provide (all-from-out "gen-lens.rkt" "make-lens.rkt" "contract.rkt"))
 (module+ test
+  (require rackunit racket/list)
   (define (set-first l v)
     (list* v (rest l)))
   (define first-lens (make-lens first set-first))
diff --git a/lens/base/contract.rkt b/lens/base/contract.rkt
new file mode 100644
index 0000000..52c38ac
--- /dev/null
+++ b/lens/base/contract.rkt
@@ -0,0 +1,41 @@
+#lang racket/base
+
+(provide lens/c)
+
+(require racket/contract/base
+         "gen-lens.rkt"
+         )
+(module+ test
+  (require rackunit
+           racket/contract/region
+           fancy-app
+           "make-lens.rkt"
+           ))
+
+(define (lens/c target/c view/c)
+  (gen-lens/c
+   [lens-view (or/c #f [lens? target/c . -> . view/c])]
+   [lens-set (or/c #f [lens? target/c view/c . -> . target/c])]
+   [focus-lens (or/c #f [lens? target/c . -> . (values view/c [view/c . -> . target/c])])]))
+
+(module+ test
+  (check-exn exn:fail:contract?
+             (λ ()
+               (define/contract lns (lens/c any/c any/c) #f)
+               (void)))
+  (define/contract lns (lens/c hash? string?)
+    (make-lens (hash-ref _ 'a) (hash-set _ 'a _)))
+  (check-equal? (lens-view lns (hash 'a "alpha" 'b "bet"))
+                "alpha")
+  (check-equal? (lens-set lns (hash 'a "alpha" 'b "bet") "alfa")
+                (hash 'a "alfa" 'b "bet"))
+  (let-lens [tgt ctxt] lns (hash 'a "alpha" 'b "bet")
+    (check-equal? tgt "alpha")
+    (check-equal? (ctxt "alfa") (hash 'a "alfa" 'b "bet"))
+    (check-exn exn:fail:contract?
+               (λ () (ctxt 'alpha))))
+  (check-exn exn:fail:contract?
+             (λ () (lens-view lns (hash 'a 'alpha 'b 'bet))))
+  (check-exn exn:fail:contract?
+             (λ () (lens-set lns (hash 'a "alpha" 'b "bet") 'alpha)))
+  )
diff --git a/lens/base/gen-lens.rkt b/lens/base/gen-lens.rkt
new file mode 100644
index 0000000..cfbd51a
--- /dev/null
+++ b/lens/base/gen-lens.rkt
@@ -0,0 +1,47 @@
+#lang racket/base
+
+(require racket/contract/base)
+(provide gen:lens
+         let-lens
+         (rename-out [lens/c gen-lens/c])
+         (contract-out 
+                       [lens? predicate/c]
+                       [lens-view (-> lens? any/c any/c)]
+                       [lens-set (-> lens? any/c any/c any/c)]
+                       [focus-lens (-> lens? any/c
+                                       (values any/c (-> any/c any/c)))]
+                       [use-applicable-lenses! (-> void?)]
+                       ))
+
+(require racket/generic fancy-app)
+
+(define-generics lens
+  (lens-view lens target)
+  (lens-set lens target x)
+  (focus-lens lens target)
+  #:fallbacks
+  [(define/generic gen-lens-view lens-view)
+   (define/generic gen-lens-set lens-set)
+   (define (lens-view lens target)
+     (let-lens (view _) lens target view))
+   (define (lens-set lens target x)
+     (let-lens (_ setter) lens target
+       (setter x)))
+   (define (focus-lens lens target)
+     (values (gen-lens-view lens target)
+             (gen-lens-set lens target _)))]
+  #:derive-property prop:procedure
+  (lambda (this target)
+    (if (lenses-applicable?)
+        (lens-view this target)
+        (error "cannot apply a non-applicable lens as a function"))))
+
+(define lenses-applicable? (make-parameter #f))
+
+(define (use-applicable-lenses!)
+  (lenses-applicable? #t))
+
+(define-syntax-rule (let-lens (view context) lens-expr target-expr body ...)
+  (let-values ([(view context) (focus-lens lens-expr target-expr)])
+    body ...))
+
diff --git a/lens/base/make-lens.rkt b/lens/base/make-lens.rkt
new file mode 100644
index 0000000..be0e4cc
--- /dev/null
+++ b/lens/base/make-lens.rkt
@@ -0,0 +1,30 @@
+#lang racket/base
+
+(require racket/contract/base)
+(provide (contract-out [make-lens (-> (-> any/c any/c)
+                                      (-> any/c any/c any/c)
+                                      lens?)]))
+
+(require "gen-lens.rkt")
+
+(module+ test
+  (require rackunit racket/list racket/function))
+
+(struct lens-struct (get set)
+  #:methods gen:lens
+  [(define (lens-view this target)
+     ((lens-struct-get this) target))
+   (define (lens-set this target x)
+     ((lens-struct-set this) target x))])
+
+(define (make-lens getter setter)
+  (lens-struct getter setter))
+
+(module+ test
+  (define (set-first l v)
+    (list* v (rest l)))
+  (define first-lens (make-lens first set-first))
+  (check-exn exn:fail? (thunk (first-lens '(a b c))))
+  (let-lens (view-first setter-first) first-lens '(1 2 3 4 5)
+    (check-eqv? view-first 1)
+    (check-equal? (setter-first 'a) '(a 2 3 4 5))))
diff --git a/lens/base/view-set.rkt b/lens/base/view-set.rkt
index 7a5b086..4f5ef2a 100644
--- a/lens/base/view-set.rkt
+++ b/lens/base/view-set.rkt
@@ -9,20 +9,12 @@
   (require rackunit))
 
 (provide
- (contract-out [lens-view (-> lens? any/c any/c)]
-               [lens-view/list (->* (any/c) #:rest (listof lens?) list?)]
-               [lens-set (-> lens? any/c any/c any/c)]
+ lens-view
+ lens-set
+ (contract-out [lens-view/list (->* (any/c) #:rest (listof lens?) list?)]
                [lens-set/list (->* (any/c) #:rest (listof2 lens? any/c) any/c)]))
 
 
-(define (lens-view lens target)
-  (let-lens (view _) lens target
-    view))
-
-(define (lens-set lens target x)
-  (let-lens (_ setter) lens target
-    (setter x)))
-
 (define (lens-view/list target . lenses)
   (map (lens-view _ target) lenses))
 

From d41677a8d7b5f148be39c578c3e3a84c33ec64f1 Mon Sep 17 00:00:00 2001
From: AlexKnauth <alexander@knauth.org>
Date: Mon, 6 Jul 2015 22:15:18 -0400
Subject: [PATCH 2/2] don't provide gen:lens

---
 lens/main.rkt | 1 +
 1 file changed, 1 insertion(+)

diff --git a/lens/main.rkt b/lens/main.rkt
index 6053f9f..c3e22cf 100644
--- a/lens/main.rkt
+++ b/lens/main.rkt
@@ -23,6 +23,7 @@
    "string.rkt"
    "struct/main.rkt"
    "vector/main.rkt")
+  gen:lens
   focus-lens
   drop-lens
   take-lens