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,14 +1698,17 @@ 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)]
+      [(_ predicate? constructor (arb? selectors ...) type-name name test-immutable?)
+       (and (eq? #f (syntax-object->datum (syntax arb?)))
+            (boolean? (syntax-object->datum #'test-immutable?)))
+       (let ([test-immutable? (syntax-object->datum #'test-immutable?)])
          (with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))]
                        [(p-apps ...) (generate-temporaries (syntax (selectors ...)))]
                        [(ctc-x ...) (generate-temporaries (syntax (selectors ...)))]
                        [(procs ...) (generate-temporaries (syntax (selectors ...)))]
                        [(selector-names ...) (generate-temporaries (syntax (selectors ...)))])
-         (syntax
+           #`(let ([predicate?-name predicate?]
-          (let ([predicate?-name predicate?]
                    [constructor-name constructor]
                    [selector-names selectors] ...)
                (λ (params ...)
@@ -1714,15 +1719,19 @@ add struct contracts for immutable structs?
                       (λ (pos-blame neg-blame src-info orig-str)
                         (let ([p-apps (procs pos-blame neg-blame src-info orig-str)] ...)
                           (λ (v)
-                         (if (and (immutable? v)
+                            (if #,(if test-immutable?
-                                  (predicate?-name v))
+                                      #'(and (predicate?-name v)
+                                             (immutable? v))
+                                      #'(predicate?-name v))
                                 (constructor-name (p-apps (selector-names v)) ...)
                                 (raise-contract-error
                                  v
                                  src-info
                                  pos-blame
                                  orig-str
-                              "expected <~a>, given: ~e"
+                                 #,(if test-immutable?
+                                       "expected immutable <~a>, given: ~e"
+                                       "expected <~a>, given: ~e")
                                  'type-name
                                  v)))))
                       #f)))))))]
@@ -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