Merge pull request #141 from AlexKnauth/contract

add lens/c

lens/base/base.rkt

@@ -12,7 +12,9 @@
                        [focus-lens (-> lens? any/c
                                        (values any/c (-> any/c any/c)))]
                        [use-applicable-lenses! (-> void?)]
-                       [lens? predicate/c]))
+                       [lens? predicate/c]
+                       [lens/c (contract? contract? . -> . contract?)]
+                       ))
 
 
 (define lenses-applicable? (make-parameter #f))
@@ -27,6 +29,9 @@
         ((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)))))

lens/base/contract.scrbl

@@ -0,0 +1,16 @@
+#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/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/dict.rkt

@@ -1,6 +1,10 @@
 #lang racket/base
 
-(provide dict-ref-lens)
+(require racket/contract/base)
+(provide (contract-out
+          [dict-ref-lens
+           (-> any/c (lens/c functional-dict? any/c))]
+          ))
 
 (require racket/dict fancy-app "base/main.rkt")
 (module+ test
@@ -10,6 +14,9 @@
   (make-lens (dict-ref _ key)
              (dict-set _ key _)))
 
+(define (functional-dict? v)
+  (and (dict? v) (dict-can-functional-set? v)))
+
 (module+ test
   (check-equal? (lens-transform/list '((a . 1) (b . 2) (c . 3)) (dict-ref-lens 'a) (* 100 _))
                 '((a . 100) (b . 2) (c . 3))))

lens/list/assoc.rkt

@@ -1,9 +1,14 @@
 #lang racket
 
-(provide
- (contract-out [assoc-lens (->* (any/c) (#:is-equal? (-> any/c any/c boolean?)) lens?)]
-               [assv-lens (-> any/c lens?)]
-               [assq-lens (-> any/c lens?)]))
+(provide (contract-out
+          [assoc-lens
+           (->* (any/c) (#:is-equal? (-> any/c any/c boolean?))
+                (lens/c (listof pair?) any/c))]
+          [assv-lens
+           (-> any/c (lens/c (listof pair?) any/c))]
+          [assq-lens
+           (-> any/c (lens/c (listof pair?) any/c))]
+          ))
 
 (require racket/list
          fancy-app

lens/list/car-cdr.rkt

@@ -1,8 +1,8 @@
 #lang racket
 
 (provide
- (contract-out [car-lens lens?]
-               [cdr-lens lens?]))
+ (contract-out [car-lens (lens/c pair? any/c)]
+               [cdr-lens (lens/c pair? any/c)]))
 
 (require "../base/main.rkt")
 

lens/list/list-ref-take-drop.rkt

@@ -2,22 +2,29 @@
 
 (provide
  (contract-out
-  [list-ref-lens (-> exact-nonnegative-integer? lens?)]
-  [take-lens (-> exact-nonnegative-integer? lens?)]
-  [drop-lens (-> exact-nonnegative-integer? lens?)]
-  [first-lens lens?]
-  [second-lens lens?]
-  [third-lens lens?]
-  [fourth-lens lens?]
-  [fifth-lens lens?]
-  [sixth-lens lens?]
-  [seventh-lens lens?]
-  [eighth-lens lens?]
-  [ninth-lens lens?]
-  [tenth-lens lens?]))
+  [list-ref-lens
+   (->i ([i exact-nonnegative-integer?])
+        [lens (i) (lens/c (list*-length-at-least/c (add1 i)) any/c)])]
+  [take-lens
+   (->i ([i exact-nonnegative-integer?])
+        [lens (i) (lens/c (list*-length-at-least/c (add1 i)) any/c)])]
+  [drop-lens
+   (->i ([i exact-nonnegative-integer?])
+        [lens (i) (lens/c (list*-length-at-least/c (add1 i)) any/c)])]
+  [first-lens   (lens/c (list*-length-at-least/c 1) any/c)]
+  [second-lens  (lens/c (list*-length-at-least/c 2) any/c)]
+  [third-lens   (lens/c (list*-length-at-least/c 3) any/c)]
+  [fourth-lens  (lens/c (list*-length-at-least/c 4) any/c)]
+  [fifth-lens   (lens/c (list*-length-at-least/c 5) any/c)]
+  [sixth-lens   (lens/c (list*-length-at-least/c 6) any/c)]
+  [seventh-lens (lens/c (list*-length-at-least/c 7) any/c)]
+  [eighth-lens  (lens/c (list*-length-at-least/c 8) any/c)]
+  [ninth-lens   (lens/c (list*-length-at-least/c 9) any/c)]
+  [tenth-lens   (lens/c (list*-length-at-least/c 10) any/c)]))
 
 (require racket/list
          fancy-app
+         "../util/improper-list-length.rkt"
          "../base/main.rkt"
          "car-cdr.rkt")
 

lens/util/immutable.rkt

@@ -0,0 +1,33 @@
+#lang racket/base
+
+(provide (all-defined-out))
+
+;; The immutable? predicate only works for strings, byte-strings, vectors, hash-tables, and boxes.
+
+(define (immutable-string? v)
+  (and (string? v) (immutable? v)))
+
+(define (immutable-bytes? v)
+  (and (bytes? v) (immutable? v)))
+
+(define (immutable-vector? v)
+  (and (vector? v) (immutable? v)))
+
+(define (immutable-hash? v)
+  (and (hash? v) (immutable? v)))
+
+(define (immutable-box? v)
+  (and (box? v) (immutable? v)))
+
+(define (list->immutable-string lst)
+  (string->immutable-string (list->string lst)))
+
+(define (list->immutable-vector lst)
+  (apply vector-immutable lst))
+
+(define (build-immutable-string n f)
+  (string->immutable-string (build-string n f)))
+
+(define (build-immutable-vector n f)
+  (vector->immutable-vector (build-vector n f)))
+

lens/util/improper-list-length.rkt

@@ -0,0 +1,45 @@
+#lang racket/base
+
+(provide list*-length
+         list*-length-at-least/c
+         )
+
+(require racket/contract/base)
+(module+ test
+  (require rackunit))
+
+(define (list*-length lst)
+  (let loop ([len 0] [lst lst])
+    (cond [(pair? lst)
+           (loop (add1 len) (cdr lst))]
+          [else len])))
+
+(define (list*-length-at-least/c i)
+  (define (pred lst)
+    (let loop ([i i] [lst lst])
+      (cond [(<= i 0) #t]
+            [(pair? lst) (loop (sub1 i) (cdr lst))]
+            [else #f])))
+  (flat-named-contract
+   `(list*-length-at-least/c ,i)
+   pred))
+
+(module+ test
+  (check-equal? (list*-length '()) 0)
+  (check-equal? (list*-length '(a)) 1)
+  (check-equal? (list*-length '(a b)) 2)
+  (check-equal? (list*-length '(a b c)) 3)
+  (check-equal? (list*-length "whatever") 0)
+  (check-equal? (list*-length 'a) 0)
+  (check-equal? (list*-length '(a . b)) 1)
+  (check-equal? (list*-length '(a b . c)) 2)
+  (check-equal? (list*-length '(a b c . d)) 3)
+  (check-true  ((list*-length-at-least/c 0) 'a))
+  (check-false ((list*-length-at-least/c 1) 'a))
+  (check-true  ((list*-length-at-least/c 1) '(a . b)))
+  (check-false ((list*-length-at-least/c 2) '(a . b)))
+  (check-true  ((list*-length-at-least/c 2) '(a b . c)))
+  (check-false ((list*-length-at-least/c 3) '(a b . c)))
+  (check-true  ((list*-length-at-least/c 3) '(a b c . d)))
+  (check-false ((list*-length-at-least/c 4) '(a b c . d)))
+  )

unstable/lens/hash-pick.rkt

@@ -1,9 +1,14 @@
 #lang racket/base
 
-(provide hash-pick-lens)
+(require racket/contract/base)
+(provide (contract-out
+          [hash-pick-lens
+           (->* [] #:rest list? (lens/c immutable-hash? immutable-hash?))]
+          ))
 
 (require racket/list
          lens/base/main
+         lens/util/immutable
          "hash.rkt"
          "join.rkt")
 

unstable/lens/hash.rkt

@@ -2,11 +2,13 @@
 
 (provide
  (contract-out
-  [hash-ref-lens (-> any/c lens?)]
-  [hash-ref-nested-lens (->* () #:rest list? lens?)]))
+  [hash-ref-lens (-> any/c (lens/c immutable-hash? any/c))]
+  [hash-ref-nested-lens (->* () #:rest list? (lens/c immutable-hash? any/c))]))
 
 (require fancy-app
-         lens)
+         lens
+         lens/util/immutable
+         )
 
 (module+ test
   (require rackunit))

unstable/lens/join.rkt

@@ -3,6 +3,7 @@
 (require fancy-app
          lens
          lens/util/list-pair-contract
+         lens/util/immutable
          unstable/sequence)
 
 (module+ test
@@ -10,10 +11,10 @@
 
 (provide
  (contract-out
-  [lens-join/list (->* () #:rest (listof lens?) lens?)]
-  [lens-join/hash (->* () #:rest (listof2 any/c lens?) lens?)]
-  [lens-join/vector (->* () #:rest (listof lens?) lens?)]
-  [lens-join/string (->* () #:rest (listof lens?) lens?)]
+  [lens-join/list (->* () #:rest (listof lens?) (lens/c any/c list?))]
+  [lens-join/hash (->* () #:rest (listof2 any/c lens?) (lens/c any/c immutable-hash?))]
+  [lens-join/vector (->* () #:rest (listof lens?) (lens/c any/c immutable-vector?))]
+  [lens-join/string (->* () #:rest (listof lens?) (lens/c any/c immutable-string?))]
   ))
 
 
@@ -84,9 +85,6 @@
    (λ (tgt) (f tgt))
    (λ (tgt v) (f-inv v))))
 
-(define (list->immutable-vector lst)
-  (apply vector-immutable lst))
-
 (define list->vector-lens
   (inverse-function-lens list->immutable-vector vector->list))
 
@@ -104,9 +102,6 @@
 (define (lens-join/string . lenses)
   (lens-compose list->string-lens (apply lens-join/list lenses)))
 
-(define (list->immutable-string lst)
-  (string->immutable-string (list->string lst)))
-
 (define list->string-lens
   (inverse-function-lens list->immutable-string string->list))
 

unstable/lens/list.rkt

@@ -8,8 +8,13 @@
 
 (provide
   (contract-out
-    [list-ref-nested-lens (->* () #:rest (listof exact-nonnegative-integer?) lens?)]
-    [list-refs-lens (->* () #:rest (listof exact-nonnegative-integer?) lens?)]))
+    [list-ref-nested-lens
+     (->* () #:rest (listof exact-nonnegative-integer?)
+          lens?)]
+    [list-refs-lens
+     (->* () #:rest (listof exact-nonnegative-integer?)
+          (lens/c list? list?))]
+    ))
 
 
 (define (list-ref-nested-lens . indices)

unstable/lens/string.rkt

@@ -1,10 +1,18 @@
 #lang racket/base
 
-(provide string-ref-lens
-         string-pick-lens)
+(require racket/contract/base)
+(provide (contract-out
+          [string-ref-lens
+           (-> exact-nonnegative-integer?
+               (lens/c immutable-string? char?))]
+          [string-pick-lens
+           (->* [] #:rest (listof exact-nonnegative-integer?)
+                (lens/c immutable-string? immutable-string?))]
+          ))
 
 (require fancy-app
          lens/base/main
+         lens/util/immutable
          "join.rkt")
 
 (module+ test
@@ -17,12 +25,12 @@
    (string-set _ i _)))
 
 (define (string-set s i c)
-  (string->immutable-string
-   (build-string (string-length s)
+  (build-immutable-string
+   (string-length s)
    (λ (j)
      (if (= i j)
          c
-                       (string-ref s j))))))
+         (string-ref s j)))))
 
 (module+ test
   (check-equal? (lens-view (string-ref-lens 2) "abc") #\c)

unstable/lens/vector.rkt

@@ -1,11 +1,21 @@
 #lang racket/base
 
-(provide vector-ref-lens
-         vector-ref-nested-lens
-         vector-pick-lens)
+(require racket/contract/base)
+(provide (contract-out
+          [vector-ref-lens
+           (-> exact-nonnegative-integer?
+               (lens/c immutable-vector? any/c))]
+          [vector-ref-nested-lens
+           (->* [] #:rest (listof exact-nonnegative-integer?)
+                (lens/c immutable-vector? any/c))]
+          [vector-pick-lens
+           (->* [] #:rest (listof exact-nonnegative-integer?)
+                (lens/c immutable-vector? immutable-vector?))]
+          ))
 
 (require fancy-app
          lens/base/main
+         lens/util/immutable
          "arrow.rkt"
          "join.rkt")
 
@@ -19,12 +29,12 @@
    (vector-set _ i _)))
 
 (define (vector-set v i x)
-  (vector->immutable-vector
-   (build-vector (vector-length v)
+  (build-immutable-vector
+   (vector-length v)
    (λ (j)
      (if (= i j)
          x
-                       (vector-ref v j))))))
+         (vector-ref v j)))))
 
 (module+ test
   (check-equal? (lens-view (vector-ref-lens 0) #(a b c)) 'a)