added unsafe list contract combinators

svn: r6096

collects/mzlib/private/contract.ss

@@ -3,8 +3,6 @@
 improve method arity mismatch contract violation error messages?
   (abstract out -> and friends even more?)
 
-add struct contracts for immutable structs?
-
 |#
 
 (module contract mzscheme
@@ -818,6 +816,7 @@ add struct contracts for immutable structs?
            listof list-immutableof 
            vectorof vector-immutableof vector/c vector-immutable/c 
            cons-immutable/c cons/c list-immutable/c list/c
+           listof-unsafe cons-unsafe/c list-unsafe/c
            box-immutable/c box/c
            promise/c
            struct/c
@@ -1570,6 +1569,9 @@ add struct contracts for immutable structs?
   (define list-immutableof
     (*-immutableof immutable-list? map-immutable immutable-list list-immutableof))
   
+  (define listof-unsafe
+    (*-immutableof list? map list listof-unsafe))
+
   (define (immutable-vector? val) (and (immutable? val) (vector? val)))
   
   (define vector-immutableof
@@ -1696,36 +1698,43 @@ add struct contracts for immutable structs?
   (define-syntax (*-immutable/c stx)
     (syntax-case stx ()
       [(_ predicate? constructor (arb? selectors ...) type-name name)
-       (eq? #f (syntax-object->datum (syntax arb?)))
+       #'(*-immutable/c predicate? constructor (arb? selectors ...) type-name name #t)]
-       (with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))]
+      [(_ predicate? constructor (arb? selectors ...) type-name name test-immutable?)
-                     [(p-apps ...) (generate-temporaries (syntax (selectors ...)))]
+       (and (eq? #f (syntax-object->datum (syntax arb?)))
-                     [(ctc-x ...) (generate-temporaries (syntax (selectors ...)))]
+            (boolean? (syntax-object->datum #'test-immutable?)))
-                     [(procs ...) (generate-temporaries (syntax (selectors ...)))]
+       (let ([test-immutable? (syntax-object->datum #'test-immutable?)])
-                     [(selector-names ...) (generate-temporaries (syntax (selectors ...)))])
+         (with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))]
-         (syntax
+                       [(p-apps ...) (generate-temporaries (syntax (selectors ...)))]
-          (let ([predicate?-name predicate?]
+                       [(ctc-x ...) (generate-temporaries (syntax (selectors ...)))]
-                [constructor-name constructor]
+                       [(procs ...) (generate-temporaries (syntax (selectors ...)))]
-                [selector-names selectors] ...)
+                       [(selector-names ...) (generate-temporaries (syntax (selectors ...)))])
-            (λ (params ...)
+           #`(let ([predicate?-name predicate?]
-              (let ([ctc-x (coerce-contract 'name params)] ...)
+                   [constructor-name constructor]
-                (let ([procs (contract-proc ctc-x)] ...)
+                   [selector-names selectors] ...)
-                  (make-proj-contract
+               (λ (params ...)
-                   (build-compound-type-name 'name (proc/ctc->ctc params) ...)
+                 (let ([ctc-x (coerce-contract 'name params)] ...)
-                   (λ (pos-blame neg-blame src-info orig-str)
+                   (let ([procs (contract-proc ctc-x)] ...)
-                     (let ([p-apps (procs pos-blame neg-blame src-info orig-str)] ...)
+                     (make-proj-contract
-                       (λ (v)
+                      (build-compound-type-name 'name (proc/ctc->ctc params) ...)
-                         (if (and (immutable? v)
+                      (λ (pos-blame neg-blame src-info orig-str)
-                                  (predicate?-name v))
+                        (let ([p-apps (procs pos-blame neg-blame src-info orig-str)] ...)
-                             (constructor-name (p-apps (selector-names v)) ...)
+                          (λ (v)
-                             (raise-contract-error
+                            (if #,(if test-immutable?
-                              v
+                                      #'(and (predicate?-name v)
-                              src-info
+                                             (immutable? v))
-                              pos-blame
+                                      #'(predicate?-name v))
-                              orig-str
+                                (constructor-name (p-apps (selector-names v)) ...)
-                              "expected <~a>, given: ~e"
+                                (raise-contract-error
-                              'type-name
+                                 v
-                              v)))))
+                                 src-info
-                   #f)))))))]
+                                 pos-blame
+                                 orig-str
+                                 #,(if test-immutable?
+                                       "expected immutable <~a>, given: ~e"
+                                       "expected <~a>, given: ~e")
+                                 'type-name
+                                 v)))))
+                      #f)))))))]
       [(_ predicate? constructor (arb? selector) correct-size type-name name)
        (eq? #t (syntax-object->datum (syntax arb?)))
        (syntax
@@ -1763,6 +1772,7 @@ add struct contracts for immutable structs?
                  #f))))))]))
   
   (define cons-immutable/c (*-immutable/c pair? cons-immutable (#f car cdr) immutable-cons cons-immutable/c))
+  (define cons-unsafe/c (*-immutable/c pair? cons (#f car cdr) cons cons-unsafe/c #f))
   (define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c))
   (define vector-immutable/c (*-immutable/c vector?
                                             vector-immutable
@@ -1838,7 +1848,7 @@ add struct contracts for immutable structs?
                                     (and (procedure? x)
                                          (procedure-arity-includes? x 1))))
                     args)
-      (error 'list/c "expected flat contracts or procedures of arity 1, got: ~a"
+      (error 'list/c "expected contracts or procedures of arity 1, got: ~a"
              (let loop ([args args]) 
                (cond
                  [(null? args) ""]
@@ -1851,6 +1861,24 @@ add struct contracts for immutable structs?
 	[(null? args) (flat-contract null?)]
 	[else (cons-immutable/c (car args) (loop (cdr args)))])))
   
+  (define (list-unsafe/c . args)
+    (unless (andmap (λ (x) (or (contract? x)
+                               (and (procedure? x)
+                                    (procedure-arity-includes? x 1))))
+                    args)
+      (error 'list/c "expected contracts or procedures of arity 1, got: ~a"
+             (let loop ([args args]) 
+               (cond
+                 [(null? args) ""]
+                 [(null? (cdr args)) (format "~e" (car args))]
+                 [else (string-append
+                        (format "~e " (car args))
+                        (loop (cdr args)))]))))
+    (let loop ([args args])
+      (cond
+	[(null? args) (flat-contract null?)]
+	[else (cons-unsafe/c (car args) (loop (cdr args)))])))
+
   (define (syntax/c ctc-in)
     (let ([ctc (coerce-contract 'syntax/c ctc-in)])
       (build-flat-contract

collects/tests/mzscheme/contract-test.ss

@@ -3072,6 +3072,180 @@
                           'neg))
    #t)
 
+  (test/pos-blame
+   'unsafe1
+   '(let ([ct (contract (listof-unsafe (boolean? . -> . boolean?)) 
+                        #f 
+                        'pos
+                        'neg)])
+      ((car ct) 1)))
+  
+  (test/neg-blame
+   'unsafe2
+   '(let ([ct (contract (listof-unsafe (boolean? . -> . boolean?)) 
+                        (list (lambda (x) x)) 
+                        'pos
+                        'neg)])
+      ((car ct) 1)))
+
+  (test/spec-passed
+   'unsafe2b
+   '(let ([ct (contract (listof-unsafe (boolean? . -> . boolean?)) 
+                        (list (lambda (x) x)) 
+                        'pos
+                        'neg)])
+      ((car ct) #t)))
+  
+  (test/neg-blame
+   'unsafe3
+   '(let ([ct (contract (listof-unsafe (number? . -> . boolean?)) 
+                        (list (lambda (x) 1)) 
+                        'pos
+                        'neg)])
+      ((car ct) #f)))
+  
+  (test/pos-blame
+   'unsafe4
+   '(let ([ct (contract (list-unsafe (number? . -> . boolean?)) 
+                        (list (lambda (x) 1)) 
+                        'pos
+                        'neg)])
+      ((car ct) 1)))
+  
+  (test/spec-passed
+   'unsafe5
+   '(let ([ct (contract (listof-unsafe (number? . -> . boolean?)) 
+                        (list (lambda (x) #t)) 
+                        'pos
+                        'neg)])
+      ((car ct) 1)))
+  
+
+  (test/pos-blame
+   'unsafe6
+   '(contract (cons-unsafe/c (boolean? . -> . boolean?) (boolean? . -> . boolean?)) 
+              #f 
+              'pos
+              'neg))
+  
+  (test/spec-passed
+   'unsafe7
+   '(contract (cons-unsafe/c (boolean? . -> . boolean?) (boolean? . -> . boolean?)) 
+              (cons (lambda (x) x) (lambda (x) x))
+              'pos
+              'neg))
+  
+  (test/neg-blame
+   'unsafe8
+   '(let ([ct (contract (cons-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                        (cons (lambda (x) 1) (lambda (x) 1))
+                        'pos
+                        'neg)])
+      ((car ct) #f)))
+  
+  (test/neg-blame
+   'unsafe9
+   '(let ([ct (contract (cons-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                        (cons (lambda (x) 1) (lambda (x) 1))
+                        'pos
+                        'neg)])
+      ((cdr ct) #f)))
+  
+  (test/pos-blame
+   'unsafe10
+   '(let ([ct (contract (cons-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                        (cons (lambda (x) 1) (lambda (x) 1)) 
+                        'pos
+                        'neg)])
+      ((car ct) 1)))
+  
+  (test/pos-blame
+   'unsafe11
+   '(let ([ct (contract (cons-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                        (cons (lambda (x) 1) (lambda (x) 1)) 
+                        'pos
+                        'neg)])
+      ((cdr ct) 1)))
+  
+  (test/spec-passed
+   'unsafe12
+   '(let ([ct (contract (cons-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                        (cons (lambda (x) #t) (lambda (x) #t)) 
+                        'pos
+                        'neg)])
+      ((car ct) 1)))
+  
+  (test/spec-passed
+   'unsafe13
+   '(let ([ct (contract (cons-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                        (cons (lambda (x) #t) (lambda (x) #t)) 
+                        'pos
+                        'neg)])
+      ((cdr ct) 1)))
+  
+  (test/spec-passed/result
+   'unsafe14
+   '(contract (cons-unsafe/c number? boolean?) 
+              (cons 1 #t) 
+              'pos
+              'neg)
+   (cons-immutable 1 #t))
+  
+  (test/pos-blame
+   'unsafe15
+   '(contract (list-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              #f
+              'pos
+              'neg))
+  
+  (test/spec-passed
+   'unsafe16
+   '(contract (list-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              (list (lambda (x) #t) (lambda (x) #t)) 
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'unsafe17
+   '(contract (list-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              (list (lambda (x) #t)) 
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'unsafe18
+   '(contract (list-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+              (list (lambda (x) #t) (lambda (x) #t) (lambda (x) #t)) 
+              'pos
+              'neg))
+  
+  (test/spec-passed
+   'unsafe19
+   '(let ([ctc (contract (list-unsafe/c (number? . -> . boolean?) (number? . -> . boolean?)) 
+                         (list (lambda (x) #t) (lambda (x) #t)) 
+                         'pos
+                         'neg)])
+      (for-each (lambda (x) (x 1)) ctc)))
+  
+  (test/spec-passed/result
+   'unsafe20
+   '(let ([ctc (contract (list-unsafe/c number?) 
+                         (list 1) 
+                         'pos
+                         'neg)])
+      (immutable? ctc))
+   #f)
+
+  (test/spec-passed/result
+   'unsafe21
+   '(let* ([orig-list (list 1 2 3)]
+           [ctc (contract (list-unsafe/c number?)
+                          orig-list
+                          'pos
+                          'neg)])
+      (eq? orig-list ctc))
+   #f)
+
   
   (test/pos-blame
    'promise/c1