Merge 84e2a93 into b7cdb6c

lens/base/base.rkt

@@ -1,52 +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]))
-
-
-(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"))))
-
-(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")
+(provide (all-from-out "gen-lens.rkt" "make-lens.rkt"))
 (module+ test
+  (require rackunit racket/list)
   (define (set-first l v)
     (list* v (rest l)))
   (define first-lens (make-lens first set-first))

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)))
+  )

lens/base/contract.scrbl

@@ -0,0 +1,15 @@
+#lang scribble/manual
+
+@(require lens/doc-util/main)
+
+@title{Lens Contracts}
+
+@defproc[(lens/c [target/c contract?] [view/c contract?]) contract?]{
+A contract constructor for lenses. The @racket[target/c] contract is used for
+the second argument in @racket[(lens-view lens target)], the second argument
+and the return value of @racket[(lens-set lens target view)], for example, the
+@racket[view/c] contract is used for the return value of
+@racket[(lens-view lens target)] and the third argument of
+@racket[(lens-set lens target view)], as well as other places where targets or
+views of the lens are used as inputs or outputs.
+}

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 ...))
+

lens/base/main.rkt

@@ -3,6 +3,7 @@
 (require "base.rkt"
          "view-set.rkt"
          "transform.rkt"
+         "contract.rkt"
          "identity.rkt"
          "compose.rkt")
 
@@ -11,5 +12,6 @@
   "base.rkt"
   "view-set.rkt"
   "transform.rkt"
+  "contract.rkt"
   "identity.rkt"
   "compose.rkt"))

lens/base/main.scrbl

@@ -6,4 +6,5 @@
 @include-section["view-set.scrbl"]
 @include-section["laws.scrbl"]
 @include-section["transform.scrbl"]
+@include-section["contract.scrbl"]
 @include-section["compose.scrbl"]

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))))

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))
 

lens/main.rkt

@@ -15,6 +15,7 @@
    "struct.rkt"
    "dict.rkt"
    )
+  gen:lens
   focus-lens
   drop-lens
   take-lens

unstable/lens/isomorphism.rkt

@@ -0,0 +1,63 @@
+#lang racket/base
+
+(provide isomorphism-lens
+         isomorphism-lens-inverse
+         isomorphism-lenses
+         )
+(module+ lenses
+  (provide string->symbol-lens symbol->string-lens
+           number->string-lens string->number-lens
+           list->vector-lens vector->list-lens
+           list->string-lens string->list-lens
+           ))
+
+(require racket/match
+         lens/base/main
+         )
+(module+ test
+  (require rackunit (submod ".." lenses)))
+
+(struct isomorphism-lens (f inv) #:transparent
+  #:methods gen:lens
+  [(define (lens-view lens tgt)
+     ((isomorphism-lens-f lens) tgt))
+   (define (lens-set lens tgt v)
+     ((isomorphism-lens-inv lens) v))])
+
+(define (isomorphism-lens-inverse lens)
+  (match lens
+    [(isomorphism-lens f inv)
+     (isomorphism-lens inv f)]))
+
+(define (isomorphism-lenses f inv)
+  (values (isomorphism-lens f inv)
+          (isomorphism-lens inv f)))
+
+(module+ lenses
+  (define-values [string->symbol-lens symbol->string-lens]
+    (isomorphism-lenses string->symbol symbol->string))
+  (define-values [number->string-lens string->number-lens]
+    (isomorphism-lenses number->string string->number))
+  (define-values [list->vector-lens vector->list-lens]
+    (isomorphism-lenses list->vector vector->list))
+  (define-values [list->string-lens string->list-lens]
+    (isomorphism-lenses list->string string->list))
+  )
+
+(module+ test
+  (test-case "string-symbol"
+    (check-equal? (lens-view string->symbol-lens "a") 'a)
+    (check-equal? (lens-set string->symbol-lens "a" 'b) "b")
+    (check-equal? (lens-view symbol->string-lens 'a) "a")
+    (check-equal? (lens-set symbol->string-lens 'a "b") 'b))
+  (test-case "number-string"
+    (check-equal? (lens-view number->string-lens 5) "5")
+    (check-equal? (lens-set number->string-lens 5 "6") 6)
+    (check-equal? (lens-view string->number-lens "5") 5)
+    (check-equal? (lens-set string->number-lens "5" 6) "6"))
+  (test-case "inverses"
+    (check-equal? (isomorphism-lens-inverse string->symbol-lens) symbol->string-lens)
+    (check-equal? (isomorphism-lens-inverse symbol->string-lens) string->symbol-lens)
+    (check-equal? (isomorphism-lens-inverse number->string-lens) string->number-lens)
+    (check-equal? (isomorphism-lens-inverse string->number-lens) number->string-lens))
+  )