add list*of

2014-10-11 22:12:48 -05:00 · 2014-10-11 22:12:48 -05:00 · ec4542383c
commit ec4542383c
parent 608ac636eb
7 changed files with 244 additions and 54 deletions
--- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl
+++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl
@ -373,14 +373,56 @@ reasons of backwards compatibility.}

 Returns a contract that recognizes a list whose every element matches
 the contract @racket[c]. Beware that when this contract is applied to
-a value, the result is not necessarily @racket[eq?] to the input.}
+a value, the result is not necessarily @racket[eq?] to the input.
+
+@examples[#:eval (contract-eval)
+                 (define/contract some-numbers
+                   (listof number?)
+                   (list 1 2 3))
+                 (define/contract just-one-number
+                   (listof number?)
+                   11)]
+
+}


@defproc[(non-empty-listof [c contract?]) list-contract?]{

 Returns a contract that recognizes non-empty lists whose elements match
 the contract @racket[c]. Beware that when this contract is applied to
-a value, the result is not necessarily @racket[eq?] to the input.}
+a value, the result is not necessarily @racket[eq?] to the input.
+
+@examples[#:eval (contract-eval)
+                 (define/contract some-numbers
+                   (non-empty-listof number?)
+                   (list 1 2 3))
+                                
+                 (define/contract not-enough-numbers
+                   (non-empty-listof number?)
+                   (list))]
+}
+
+@defproc[(list*of [c contract?]) contract?]{
+
+Returns a contract that recognizes improper lists whose elements match
+the contract @racket[c]. If an improper list is created with @racket[cons],
+then its @racket[car] position is expected to match @racket[c] and
+its @racket[cdr] position is expected to be @racket[(list*of c)]. Otherwise,
+it is expected to match @racket[c]. Beware that when this contract is applied to
+a value, the result is not necessarily @racket[eq?] to the input.
+
+@examples[#:eval (contract-eval)
+                 (define/contract improper-numbers
+                   (list*of number?)
+                   (cons 1 (cons 2 3)))
+                                
+                 (define/contract not-improper-numbers
+                   (list*of number?)
+                   (list 1 2 3))]
+
+@history[#:added "6.1.1.1"]
+}
+

@defproc[(cons/c [car-c contract?] [cdr-c contract?]) contract?]{

--- a/pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt
@ -47,6 +47,7 @@
 (check-not-exn (λ () (test-contract-generation (listof boolean?))))
 (check-not-exn (λ () (test-contract-generation (listof some-crazy-predicate?))))
 (check-not-exn (λ () (test-contract-generation (non-empty-listof boolean?))))
+(check-not-exn (λ () (test-contract-generation (list*of boolean?))))
 (check-not-exn (λ () (test-contract-generation (list/c boolean? number?))))
 (check-not-exn (λ () ((car (test-contract-generation (list/c (-> number? number?)))) 0)))

--- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/list-contract.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/list-contract.rkt
@ -52,6 +52,11 @@
   '(list-contract? (listof any/c))
   #t)
  
+  (test/spec-passed/result
+   'list-contract-10b
+   '(list-contract? (list*of any/c))
+   #f)
+  
  (test/spec-passed/result
   'list-contract-11
   '(list-contract? (non-empty-listof any/c))
--- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/list.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/list.rkt
@ -11,4 +11,56 @@
  (test/no-error '(list/c 'x "x" #t #f #\c #rx"a" #rx#"b"))
  
  (test/pos-blame 'list1 '(contract (list/c 1 2) (list 1 3) 'pos 'neg))
-  (test/no-error '(contract (list/c 1 2) (list 1 2) 'pos 'neg)))
+  (test/no-error '(contract (list/c 1 2) (list 1 2) 'pos 'neg))
+  
+  (test/spec-passed/result 
+   'listof1
+   '(contract (listof integer?) '(1 2 3) 'pos 'neg)
+   '(1 2 3))
+  (test/spec-passed/result 
+   'listof2
+   '(contract (listof integer?) '() 'pos 'neg)
+   '())
+  (test/pos-blame 
+   'listof3
+   '(contract (listof integer?) #f 'pos 'neg))
+  (test/pos-blame 
+   'listof4
+   '(contract (listof integer?) (cons 1 2) 'pos 'neg))
+  (test/pos-blame 
+   'listof5
+   '(contract (listof integer?) (list #f #t) 'pos 'neg))
+  
+  (test/spec-passed/result 
+   'nelistof1
+   '(contract (non-empty-listof integer?) '(1 2 3) 'pos 'neg)
+   '(1 2 3))
+  (test/pos-blame  
+   'nelistof2
+   '(contract (non-empty-listof integer?) '() 'pos 'neg))
+  (test/pos-blame 
+   'nelistof3
+   '(contract (non-empty-listof integer?) #f 'pos 'neg))
+  (test/pos-blame 
+   'nelistof4
+   '(contract (non-empty-listof integer?) (cons 1 2) 'pos 'neg))
+  (test/pos-blame 
+   'nelistof5
+   '(contract (non-empty-listof integer?) (list #f #t) 'pos 'neg))
+  
+  (test/spec-passed/result 
+   'imlistof1
+   '(contract (list*of integer?) '(1 2 . 3) 'pos 'neg)
+   '(1 2 . 3))
+  (test/pos-blame
+   'imlistof2
+   '(contract (list*of integer?) '() 'pos 'neg))
+  (test/pos-blame 
+   'imlistof3
+   '(contract (list*of integer?) #f 'pos 'neg))
+  (test/pos-blame 
+   'imlistof4
+   '(contract (list*of integer?) (list 1 2) 'pos 'neg))
+  (test/pos-blame 
+   'imlistof5
+   '(contract (list*of integer?) (cons #f #t) 'pos 'neg)))
--- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt
@ -217,17 +217,15 @@

  (test-name '(listof boolean?) (listof boolean?))
  (test-name '(listof any/c) (listof any/c))
-  (test-name '(listof boolean?) (listof boolean?))
-  (test-name '(listof any/c) (listof any/c))
-  (test-name '(listof boolean?) (listof boolean?))
  (test-name '(listof (-> boolean? boolean?)) (listof (-> boolean? boolean?)))

  (test-name '(non-empty-listof boolean?) (non-empty-listof boolean?))
  (test-name '(non-empty-listof any/c) (non-empty-listof any/c))
-  (test-name '(non-empty-listof boolean?) (non-empty-listof boolean?))
-  (test-name '(non-empty-listof any/c) (non-empty-listof any/c))
-  (test-name '(non-empty-listof boolean?) (non-empty-listof boolean?))
  (test-name '(non-empty-listof (-> boolean? boolean?)) (non-empty-listof (-> boolean? boolean?)))
+  
+  (test-name '(list*of boolean?) (list*of boolean?))
+  (test-name '(list*of any/c) (list*of any/c))
+  (test-name '(list*of (-> boolean? boolean?)) (list*of (-> boolean? boolean?)))


  (test-name '(vectorof boolean?) (vectorof boolean?))
--- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
@ -160,7 +160,9 @@
         (cons/c (<=/c 1) (cons/c (<=/c 2) (listof (<=/c 3)))) 
         (listof (<=/c 4)))
  (ctest #f contract-stronger? (listof number?) (cons/c number? (cons/c number? (listof any/c))))
-    
+  (ctest #t contract-stronger? (list*of (<=/c 2)) (list*of (<=/c 3)))
+  (ctest #f contract-stronger? (list*of (<=/c 3)) (list*of (<=/c 2)))
+  
  (ctest #f contract-stronger? (vectorof (<=/c 3)) (vectorof (<=/c 4)))
  (ctest #f contract-stronger? (vectorof (<=/c 3)) (vectorof (<=/c 4)))
  (ctest #t contract-stronger? (vectorof (<=/c 3) #:immutable #t) (vectorof (<=/c 4) #:immutable #t))
--- a/racket/collects/racket/contract/private/misc.rkt
+++ b/racket/collects/racket/contract/private/misc.rkt
@ -20,7 +20,7 @@
         string-len/c
         false/c
         printable/c
-         listof non-empty-listof cons/c list/c
+         listof list*of non-empty-listof cons/c list/c
         promise/c
         syntax/c
         
@ -468,9 +468,14 @@
    (define eg (generate/choose (listof-ctc-elem-c ctc) fuel))
    (if eg
        (λ ()
-          (let loop ([so-far (if (pe-listof-ctc? ctc)
-                                 '()
-                                 (list (eg)))])
+          (let loop ([so-far (cond
+                               [(pe-listof-ctc? ctc)
+                                '()]
+                               [(ne-listof-ctc? ctc)
+                                (list (eg))]
+                               [else
+                                ;; improper list
+                                (eg)])])
            (rand-choice
             [1/5 so-far]
             [else (loop (cons (eg) so-far))])))
@ -488,17 +493,27 @@
       (define env (generate-env))
       (values
        (λ (lst)
-          (env-stash env elem-ctc (oneof lst)))
+          (env-stash env elem-ctc 
+                     (oneof
+                      (if (im-listof-ctc? ctc)
+                          (improper-list->list lst)
+                          lst))))
        (list elem-ctc)))]))

+(define (improper-list->list l)
+  (cond
+    [(pair? l) (cons (car l) (improper-list->list (cdr l)))]
+    [else (list l)]))
+
 (define (listof-stronger this that)
  (define this-elem (listof-ctc-elem-c this))
  (cond
    [(listof-ctc? that)
     (define that-elem (listof-ctc-elem-c that))
-     (and (if (pe-listof-ctc? this)
-              (pe-listof-ctc? that)
-              #t)
+     (and (cond
+            [(pe-listof-ctc? this) (pe-listof-ctc? that)]
+            [(im-listof-ctc? this) (im-listof-ctc? that)]
+            [else #t])
          (contract-stronger? this-elem that-elem))]
    [(the-cons/c? that)
     (define hd-ctc (the-cons/c-hd-ctc that))
@ -520,9 +535,13 @@
 (define (non-empty-list? x) (and (pair? x) (list? x)))

 (define (list-name ctc)
-  (build-compound-type-name (if (pe-listof-ctc? ctc)
-                                'listof
-                                'non-empty-listof)
+  (build-compound-type-name (cond
+                              [(pe-listof-ctc? ctc)
+                               'listof]
+                              [(ne-listof-ctc? ctc)
+                               'non-empty-listof]
+                              [(im-listof-ctc? ctc)
+                               'list*of])
                            (listof-ctc-elem-c ctc)))

 (define (list-fo-check ctc)
@ -538,8 +557,17 @@
       (and (list? v)
            (pair? v)
            (for/and ([e (in-list v)])
-              (elem-fo? e))))]))
-     
+              (elem-fo? e))))]
+    [(im-listof-ctc? ctc)
+     (λ (v)
+       (let loop ([v v])
+         (cond
+           [(pair? v) 
+            (and (elem-fo? (car v))
+                 (loop (cdr v)))]
+           [else
+            (elem-fo? v)])))]))
+
 (define (listof-projection ctc)
  (define elem-proj (contract-projection (listof-ctc-elem-c ctc)))
  (define pred? (if (pe-listof-ctc? ctc)
@ -549,19 +577,37 @@
    (define elem-proj+blame (elem-proj (blame-add-listof-context blame)))
    (cond
      [(flat-listof-ctc? ctc)
-       (λ (val)
-         (if (pred? val)
-             (begin
-               (for ([x (in-list val)])
-                 (elem-proj+blame x))
-               val)
-             (raise-listof-blame-error blame val (pe-listof-ctc? ctc) #f)))]
+       (if (im-listof-ctc? ctc)
+           (λ (val)
+             (let loop ([val val])
+               (cond
+                 [(pair? val)
+                  (elem-proj+blame (car val))
+                  (loop (cdr val))]
+                 [else
+                  (elem-proj+blame val)]))
+             val)
+           (λ (val)
+             (if (pred? val)
+                 (begin
+                   (for ([x (in-list val)])
+                     (elem-proj+blame x))
+                   val)
+                 (raise-listof-blame-error blame val (pe-listof-ctc? ctc) #f))))]
      [else
-       (λ (val)
-         (if (pred? val)
-             (for/list ([x (in-list val)])
-               (elem-proj+blame x))
-             (raise-listof-blame-error blame val (pe-listof-ctc? ctc) #f)))])))
+       (if (im-listof-ctc? ctc)
+           (λ (val) 
+             (let loop ([val val])
+               (cond
+                 [(pair? val)
+                  (cons (elem-proj+blame (car val))
+                        (loop (cdr val)))]
+                 [else (elem-proj+blame val)])))
+           (λ (val)
+             (if (pred? val)
+                 (for/list ([x (in-list val)])
+                   (elem-proj+blame x))
+                 (raise-listof-blame-error blame val (pe-listof-ctc? ctc) #f))))])))

 (define (listof-val-first-projection ctc)
  (define elem-proj (get/build-val-first-projection (listof-ctc-elem-c ctc)))
@ -572,22 +618,43 @@
    (define elem-proj+blame (elem-proj (blame-add-listof-context blame)))
    (cond
      [(flat-listof-ctc? ctc)
-       (λ (val)
-         (if (pred? val)
+       (if (im-listof-ctc? ctc)
+           (λ (val)
             (λ (neg-party)
-               (for ([x (in-list val)])
-                 ((elem-proj+blame x) neg-party))
-               val)
-             (λ (neg-party)
-               (raise-listof-blame-error blame val (pe-listof-ctc? ctc) neg-party))))]
+               (let loop ([val val])
+                 (cond
+                   [(pair? val)
+                    ((elem-proj+blame (car val)) neg-party)
+                    (loop (cdr val))]
+                   [else 
+                    ((elem-proj+blame val) neg-party)]))
+               val))
+           (λ (val)
+             (if (pred? val)
+                 (λ (neg-party)
+                   (for ([x (in-list val)])
+                     ((elem-proj+blame x) neg-party))
+                   val)
+                 (λ (neg-party)
+                   (raise-listof-blame-error blame val (pe-listof-ctc? ctc) neg-party)))))]
      [else
-       (λ (val)
-         (if (pred? val)
-             (λ (neg-party)
-               (for/list ([x (in-list val)])
-                 ((elem-proj+blame x) neg-party)))
-             (λ (neg-party)
-               (raise-listof-blame-error blame val (pe-listof-ctc? ctc) neg-party))))])))
+        (if (im-listof-ctc? ctc)
+            (λ (val)
+              (λ (neg-party)
+                (let loop ([val val])
+                  (cond
+                    [(pair? val)
+                     (cons ((elem-proj+blame (car val)) neg-party)
+                           (loop (cdr val)))]
+                    [else 
+                     ((elem-proj+blame val) neg-party)]))))
+            (λ (val)
+              (if (pred? val)
+                  (λ (neg-party)
+                    (for/list ([x (in-list val)])
+                      ((elem-proj+blame x) neg-party)))
+                  (λ (neg-party)
+                    (raise-listof-blame-error blame val (pe-listof-ctc? ctc) neg-party)))))])))

 (define flat-prop
  (build-flat-contract-property
@ -598,7 +665,7 @@
   #:generate listof-generate
   #:exercise listof-exercise
   #:stronger listof-stronger
-   #:list-contract? (λ (c) #t)))
+   #:list-contract? (λ (c) (not (im-listof-ctc? c)))))
 (define chap-prop
  (build-chaperone-contract-property
   #:name list-name
@ -608,7 +675,7 @@
   #:generate listof-generate
   #:exercise listof-exercise
   #:stronger listof-stronger
-   #:list-contract? (λ (c) #t)))
+   #:list-contract? (λ (c) (not (im-listof-ctc? c)))))
 (define full-prop
  (build-contract-property
   #:name list-name
@ -618,7 +685,7 @@
   #:generate listof-generate
   #:exercise listof-exercise
   #:stronger listof-stronger
-   #:list-contract? (λ (c) #t)))
+   #:list-contract? (λ (c) (not (im-listof-ctc? c)))))

 (struct listof-ctc (elem-c))

@ -654,9 +721,26 @@
  #:property prop:custom-write custom-write-property-proc
  #:property prop:contract full-prop)

+;; improper lists
+(struct im-listof-ctc listof-ctc ())
+
+;; improper, flat
+(struct imf-listof-ctc im-listof-ctc ()
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:flat-contract flat-prop)
+;; improper, chaperone
+(struct imc-listof-ctc im-listof-ctc ()
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:chaperone-contract chap-prop)
+;; improper, impersonator
+(struct imi-listof-ctc im-listof-ctc ()
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:contract full-prop)
+
 (define (flat-listof-ctc? x)
  (or (pef-listof-ctc? x)
-      (nef-listof-ctc? x)))
+      (nef-listof-ctc? x)
+      (imf-listof-ctc? x)))

 (define (ne->pe-ctc ne-ctc)
  (define elem-ctc (listof-ctc-elem-c ne-ctc))
@ -675,11 +759,17 @@
    [(chaperone-contract? c) (nec-listof-ctc c)]
    [else (nei-listof-ctc c)]))
 (define/subexpression-pos-prop (listof raw-c)
-  (define c (coerce-contract 'non-empty-listof raw-c))
+  (define c (coerce-contract 'listof raw-c))
  (cond
    [(flat-contract? c) (pef-listof-ctc c)]
    [(chaperone-contract? c) (pec-listof-ctc c)]
    [else (pei-listof-ctc c)]))
+(define/subexpression-pos-prop (list*of raw-c)
+  (define c (coerce-contract 'list*of raw-c))
+  (cond
+    [(flat-contract? c) (imf-listof-ctc c)]
+    [(chaperone-contract? c) (imc-listof-ctc c)]
+    [else (imi-listof-ctc c)]))


 (define (blame-add-car-context blame) (blame-add-context blame "the car of"))