contracts for list-ref etc.

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