extending option contracts; now handle procedures, vectors, hashes, struct instances, adding support for invariants for vectors, hashes and struct instances

collects/unstable/options.rkt

@@ -1,34 +1,82 @@
 #lang racket
 
 
-(provide option/c transfer-option exercise-option waive-option)
+(provide option/c transfer-option exercise-option waive-option invariant/c)
 
 
 (require syntax/location 
-         (for-syntax racket/provide-transform))
+         (for-syntax racket/provide-transform)
+         (for-syntax racket/list)
+         (for-syntax racket/struct-info))
+
+(define-for-syntax (get-struct-info id who)
+  (cond
+    [(and (identifier? id)
+          (struct-info? (syntax-local-value id (λ () #f))))
+     (let ([si (extract-struct-info (syntax-local-value id))])  
+       (with-syntax ([id id]
+                     [pred (third si)] 
+                     [(accessor ...) (fourth si)]
+                     [(mutator ...) (fifth si)])
+         #'(list pred (list accessor ...) (list mutator ...) 'id)))]
+    [else
+     (raise-syntax-error who "expected a struct identifier" id)]))
+
+
+(define-for-syntax (convert-args args this-one who) 
+  (let loop ([args args]
+             [new-args null])
+    (cond
+      [(null? args) (reverse new-args)]
+      [(keyword? (syntax-e (car args)))
+       (if (null? (cdr args))
+           (reverse (cons (car args) new-args))
+           (cond [(eq? (syntax-e (car args)) '#:struct)
+                  (loop (cddr args)
+                        (list* (get-struct-info (cadr args) who) (car args) new-args))]
+                 [else
+                  (loop (cddr args)
+                        (list* (cadr args) (car args) new-args))]))]
+      [else
+       (loop (cdr args)
+             (cons (syntax-property
+                    (car args)
+                    'racket/contract:positive-position
+                    this-one)
+                   new-args))])))
+
+(define (same-type v s-info)
+  (let ([pred (first s-info)])
+    (and pred (pred v))))
+
+(define (no-mutators? s-info)
+  (if (symbol? s-info) 
+      #t
+      (andmap boolean? (third s-info))))
 
 
 (struct info (val proj blame))
 
+
 (define-values (impersonator-prop:proxy proxy? proxy-info) 
   (make-impersonator-property 'proxy))
 
 
-(define (build-proxy val proj blame)
+(define (build-proxy ctc val proj blame)
   (let ([proxy-info (info val proj blame)])
     (cond [(procedure? val)
            (chaperone-procedure
             val
             values
-            impersonator-prop:proxy 
-            proxy-info)]
+            impersonator-prop:contracted ctc
+            impersonator-prop:proxy proxy-info)]
           [(vector? val)
            (chaperone-vector
             val
             (λ (v i val) val)
             (λ (v i val) val)
-            impersonator-prop:proxy 
-            proxy-info)]
+            impersonator-prop:contracted ctc
+            impersonator-prop:proxy proxy-info)]
           [(hash? val)
            (chaperone-hash
             val
@@ -36,17 +84,15 @@
             (λ (h k v) (values k v))
             (λ (h k) k)
             (λ (h k) k)
-            impersonator-prop:proxy 
-            proxy-info)]
-          [(struct? val)
-           (chaperone-hash
+            impersonator-prop:contracted ctc
+            impersonator-prop:proxy proxy-info)]
+          [else 
+           (chaperone-struct
             val
-            (λ (h k) (values k (λ (h k v) v)))
-            (λ (h k v) (values k v))
-            (λ (h k) k)
-            (λ (h k) k)
-            impersonator-prop:proxy 
-            proxy-info)])))
+            (first (second (option-structid ctc)))
+            (λ (v f) f)
+            impersonator-prop:contracted ctc
+            impersonator-prop:proxy proxy-info)])))
 
 
 (define (run-tester tester val orig-ctc blame here)
@@ -55,21 +101,66 @@
         [option-blame
          (λ (blame context)
            (blame-add-context blame context))])  
-    (unless (tester ((proj 
-                      (option-blame 
-                       blame
-                       (format "in option contract tester ~e" tester))) 
-                     val))
+    (unless (tester ((proj indy-blame) val))
       (raise-blame-error 
-       (option-blame indy-blame (format "option contract tester ~e failure" tester)) 
+       (option-blame indy-blame (format "option contract tester ~e of" tester)) 
        val
        ""))))
 
-(struct option (orig-ctc tester here)
+
+(define (optionc-name c)
+  (apply build-compound-type-name 'option/c 
+         (contract-name (option-orig-ctc c))
+         (append 
+          (if (eq? (option-tester c) 'dont-care)
+              null
+              (list '#:tester (option-tester c)))
+          (if (eq? (option-flat c) #f)
+              null
+              (list '#:flat? #t))
+           (if (eq? (option-immutable c) 'dont-care)
+              null
+              (list '#:immutable (option-immutable c)))
+           (if (eq? (option-invariant c) 'dont-care)
+              null
+              (list '#:invariant (option-invariant c)))
+           (if (eq? (option-structid c) 'none)
+              null
+              (list '#:struct (fourth (option-structid c)))))))
+
+
+
+
+(define (check-option c val fail) 
+  (let ([orig-ctc (option-orig-ctc c)]
+        [structid (option-structid c)]
+        [invariant (option-invariant c)]
+        [immutable (option-immutable c)]
+        [flat (option-flat c)])
+    (when (and (eq? invariant 'dont-care)
+               (or  (not (eq? immutable 'dont-care))
+                    (not (eq? flat #f))))
+          (fail val '(expected "an invariant keyword argument (based on presence of other keyword arguments)")))
+    (unless (or (and (procedure? val) (eq? structid 'none))
+                (and (vector? val) (eq? structid 'none))
+                (and (hash? val) (eq? structid 'none))
+                (and (not (eq? structid 'none)) (same-type val structid)))
+      (if (eq? structid 'none)
+          (fail val '(expected "a procedure or a vector or a hash" given: "~e") val)  
+          (fail val '(expected "a struct of type ~a" given: "~e") (fourth structid) val)))))
+
+
+
+(define (build-orig-proj c inv flat immutable structid here)
+  (cond [(eq? inv 'dont-care) (option-orig-ctc c)]
+        [else
+         (invariantc (option-orig-ctc c) inv #:struct structid #:flat? flat #:immutable immutable here)]))
+
+(struct option (orig-ctc tester invariant  flat immutable structid here)
   #:property prop:contract
   (build-contract-property
    #:name 
-   (λ (ctc) (contract-name (option-orig-ctc ctc)))
+   optionc-name
    #:first-order
    (λ (ctc)
      (λ (val)
@@ -77,37 +168,55 @@
    #:projection
    (λ (ctc)
      (λ (blame)
+       (define raise-blame (λ (val . args) 
+                             (apply raise-blame-error blame val args)))
        (λ (val)
-         (let  ([tester (option-tester ctc)]
+         (check-option ctc val raise-blame)
+         (let*  ([tester (option-tester ctc)]
+                 [invariant (option-invariant ctc)]
+                 [flat (option-flat ctc)]
+                 [immutable (option-immutable ctc)]
+                 [structid (option-structid ctc)]
+                 [here (option-here ctc)]
                  [orig-ctc (option-orig-ctc ctc)]
-                [here (option-here ctc)])
+                 [exec-ctc (build-orig-proj ctc invariant flat immutable structid here)])
            (unless (symbol? tester)
              (run-tester tester val orig-ctc blame here))
-           (build-proxy val (contract-projection orig-ctc) blame)))))))
+           (build-proxy ctc val (contract-projection exec-ctc) blame)))))))
+
+(define (build-option ctc
+                      #:tester [tester 'dont-care]
+                      #:invariant [invariant 'dont-care] 
+                      #:flat? [flat #f] 
+                      #:immutable [immutable 'dont-care]
+                      #:struct [structid 'none]
+                      here)
+  (option ctc tester invariant flat immutable structid here))
+
 
-(define (build-option ctc here #:tester [tester 'dont-care])
-  (option ctc tester here))
 
 (define-syntax (option/c stx)
   (syntax-case stx ()
-    [(_ con) 
+    [(optionc arg ...) 
+     (let ([args (syntax->list #'(arg ...))]
+           [this-one (gensym 'option-ctc)])
+       (with-syntax ([(new-arg ...) (convert-args args this-one 'option/c)])
          (syntax-property
-      #`(build-option con (quote-module-name))
+          (syntax/loc stx
+            (build-option new-arg ... (quote-module-name)))
           'racket/contract:contract
-      (vector (gensym 'option/c)
-              (list (car (syntax-e stx)))
-              '()))]
-    [(_ con key tester) 
-     (syntax-property
-      #`(build-option con (quote-module-name) key tester)
-      'racket/contract:contract
-      (vector (gensym 'option/c)
-              (list (car (syntax-e stx)))
-              '()))]))
+          (vector this-one (list #'optionc) null))))]))
 
-(struct transfer ()
+
+
+(define (transferc-name c)
+  (apply build-compound-type-name 'transfer-option (transfer-id c) empty))
+
+(struct transfer (id)
   #:property prop:contract
   (build-contract-property
+   #:name 
+   transferc-name
    #:projection
    (λ (ctc)
      (λ (blame)
@@ -115,23 +224,28 @@
          (let ([option-blame
                 (blame-add-context 
                  blame
-                 (format "option contract transfer failure: ~a does not have an option" val))]
+                 (format "~a does not have an option in" val)
+                 #:important (format "~a" (transfer-id ctc)))]
                [pos-blame (blame-positive blame)]
                [neg-blame (blame-negative blame)])
            (cond [(proxy? val)
                   (let ((info (proxy-info val)))
                     (build-proxy
+                     (value-contract val)
                      (info-val info)
                      (info-proj info)
                      (blame-update (info-blame info) pos-blame neg-blame)))]
                  [else (raise-blame-error option-blame val "")])))))))
 
-(define-syntax transfer/c
-  (syntax-id-rules ()
-    [_ (transfer)]))
-
-(define-for-syntax (fresh-names l)
-  (map (lambda (x) (datum->syntax #f (gensym x))) (syntax->datum l)))
+(define-syntax (transfer/c stx)
+  (syntax-case stx ()
+    [(transferc id) 
+     (let ([this-one (gensym 'transfer-ctc)])
+       (syntax-property
+          (syntax/loc stx
+            (transfer 'id))
+          'racket/contract:contract
+          (vector this-one null (list #'transferc))))]))
 
 (define-syntax transfer-option
   (make-provide-pre-transformer
@@ -148,20 +262,255 @@
          (with-syntax ([(new-id ...) (generate-temporaries #'(id ...))])
            #`(begin
                (begin (define new-id id) ...)
-               (provide (contract-out [rename new-id id transfer/c] ...)))))])
+               (provide (contract-out [rename new-id id (transfer/c id)] ...)))))])
      #`(combine-out))))
 
 (define (exercise-option val)
-  (cond [(proxy? val)
+  (cond [(and (has-contract? val) (option? (value-contract val)))
          (let ((info (proxy-info val)))
            (((info-proj info)
              (info-blame info))
             (info-val info)))]
-        [else (error 'exercise-error "~a has no option to exercise" val)]))
+        [else (error 'exercise-option-error "~a has no option to exercise" val)]))
 
 (define (waive-option val)
-  (cond [(proxy? val) (info-val (proxy-info val))]
-        [else (error 'exercise-error "~a has no option to exercise" val)]))
+  (cond [(and (has-contract? val) (option? (value-contract val))) (info-val (proxy-info val))]
+        [else (error 'waive-option-error "~a has no option to waive" val)]))
 
                            
 
+;                                                                                                                
+;                                                                                                                
+;                                                                                                                
+;                                                                                                   ;            
+;      ;                                                 ;                                         ;             
+;      ;                                                 ;                           ;             ;             
+;                                                                                    ;            ;              
+;    ;;;      ;; ;;;   ;;;   ;;;    ;;;;    ;;;  ;;    ;;;        ;;;;    ;; ;;;   ;;;;;;;        ;       ;;; ;  
+;      ;       ;;   ;   ;     ;         ;     ;;;        ;            ;    ;;   ;    ;            ;      ;   ;;  
+;      ;       ;    ;   ;    ;          ;     ;          ;            ;    ;    ;    ;           ;      ;     ;  
+;      ;       ;    ;    ;   ;     ;;;;;;     ;          ;       ;;;;;;    ;    ;    ;           ;      ;        
+;      ;       ;    ;     ; ;     ;     ;     ;          ;      ;     ;    ;    ;    ;          ;       ;        
+;      ;       ;    ;     ; ;     ;    ;;     ;          ;      ;    ;;    ;    ;    ;    ;     ;        ;    ;  
+;   ;;;;;;;   ;;;  ;;;    ;;;      ;;;; ;;  ;;;;;;    ;;;;;;;    ;;;; ;;  ;;;  ;;;    ;;;;     ;          ;;;;   
+;                                                                                              ;                 
+;                                                                                                                
+;                                                                                                                
+;                                                                                                                
+;                                                                                                                
+
+
+
+(define-struct invariant-info (ctc invariant structid flat immutable here))
+
+
+
+
+(define (invariantc-name c)
+  (let ([immutable (invariant-info-immutable c)]
+        [flat (invariant-info-flat c)]
+        [invariant (invariant-info-invariant c)]
+        [structid  (invariant-info-structid c)])
+    (apply build-compound-type-name 'invariant/c 
+           (contract-name (invariant-info-ctc c))
+           invariant
+           (append
+            (if (eq? structid 'none)
+                null
+                (list '#:struct (fourth structid)))
+            (if flat
+                (list '#:flat? #t)
+                null)
+            (if (eq? immutable 'dont-care)
+                null
+                (list '#:immutable immutable))))))
+
+
+
+
+
+(define (check-invariant c) 
+  (let ([orig-ctc (invariant-info-ctc c)]
+        [immutable (invariant-info-immutable c)]
+        [invariant (invariant-info-invariant c)]
+        [structid (invariant-info-structid c)])
+    (λ (val fail first-order?)
+      (unless (or (and (vector? val) (eq? structid 'none))
+                  (and (hash? val) (eq? structid 'none))
+                  (and (not (eq? structid 'none)) (same-type val structid)))
+        (if (eq? structid 'none)
+            (fail val '(expected "a vector or a hash" given: "~e") val)  
+            (fail val '(expected "a struct of type ~a" given: "~e") (fourth structid) val)))
+      (cond
+        [(eq? immutable #t)
+         (unless (or (immutable? val) (and (not (symbol? structid)) (no-mutators? structid)))
+           (fail val '(expected "immutable data" given: "~e") val))]
+        [(eq? immutable #f)
+         (when (or (immutable? val) 
+                   (and (not (symbol? structid)) (no-mutators? structid)))
+           (fail val '(expected "mutable data" given: "~e") val))]
+        [else (void)])       
+      (when first-order?
+        (unless (contract-first-order-passes? orig-ctc val)
+          (let ([kind (cond [(vector? val) "vector"]
+                            [(hash? val) "hash"]
+                            [else "struct"])])                            
+            (fail val '(expected: "~s that satisfies ~s" given: "~e") kind (contract-name orig-ctc) val))))
+      #t)))
+
+(define (invariantc-first-order ctc)
+  (let ([check (check-invariant ctc)])
+    (λ (val)
+      (let/ec return
+        (check val (λ _ (return #f)) #t)))))
+
+(define-struct (immutable-invariantc invariant-info) ()
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:name invariantc-name
+   #:first-order invariantc-first-order
+   #:projection 
+   (λ (ctc) 
+     (define check (check-invariant ctc))
+     (λ (blame) 
+       (define raise-blame (λ (val . args) 
+                             (apply raise-blame-error blame val args)))
+       (λ (val)
+         (check val raise-blame #f)
+         (let ([orig-proj (contract-projection (invariant-info-ctc ctc))]
+               [indy-blame  (blame-replace-negative blame (invariant-info-here ctc))]
+               [invariant (invariant-info-invariant ctc)])
+           (unless (invariant ((orig-proj indy-blame) val))
+             (let ([kind (cond [(vector? val) 'vector]
+                               [(hash? val) 'hash]
+                               [else 'struct])])  
+               (raise-blame-error 
+                blame
+                val
+                (format "expected ~s that satisfies ~s given: ~e" kind invariant val))))
+           ((orig-proj blame) val)))))))
+
+
+
+(define (build-inv-proxy ctc val inv proj blame indy-blame impersonate?)
+  (define (run-invariant kind blame) 
+    (unless (inv ((proj indy-blame) val))
+      (raise-blame-error 
+       blame
+       val
+       (format "expected ~s that satisfies ~s given: ~e" kind inv val))))
+  (cond [(vector? val)
+         (let ([vector-wrapper 
+                (λ (wrapper ) 
+                  (wrapper
+                   ((proj blame) val)
+                   (λ (vec i v) (run-invariant 'vector blame) v)
+                   (λ (vec i v) (vector-set! vec i v) (run-invariant 'vector (blame-swap blame)) v)
+                   impersonator-prop:contracted ctc))])
+           (if impersonate? 
+               (vector-wrapper impersonate-vector) 
+               (vector-wrapper chaperone-vector)))]
+        [(hash? val)
+         (let ([hash-wrapper
+                (λ (wrapper) 
+                  (wrapper
+                   ((proj blame) val)
+                   (λ (h k) (run-invariant 'hash blame) (values k (λ (h k v) v)))
+                   (λ (h k v) (if (immutable? h) (hash-set h k v) (hash-set! h k v)) (run-invariant 'hash (blame-swap blame)) (values k v))
+                   (λ (h k) (if (immutable? h) (hash-remove h k) (hash-remove! h k)) (run-invariant 'hash (blame-swap blame)) k)
+                   (λ (h k) (run-invariant 'hash blame) k)
+                   impersonator-prop:contracted ctc))])
+           (if impersonate? 
+               (hash-wrapper impersonate-hash) 
+               (hash-wrapper chaperone-hash)))]
+        [else
+         (let* ([s-info (invariant-info-structid ctc)]
+                [a-wrap (λ (v f) (run-invariant 'struct blame) f)]
+                [m-wrap (λ (m)
+                          (λ (v f) 
+                            (m v f) (run-invariant 'struct (blame-swap blame)) f))]
+                [wrapped-accessors (foldr (λ (first rest) 
+                                            (if (procedure? first)
+                                                (list* first a-wrap rest)
+                                                rest))
+                                            '()
+                                            (second s-info))]
+                [wrapped-mutators (foldr (λ (first rest) 
+                                           (if (procedure? first)
+                                               (list* first (m-wrap first) rest)
+                                               rest))
+                                           '()
+                                           (third s-info))]
+                [struct-wrapper
+                 (λ (wrapper) 
+                   (apply
+                    wrapper
+                    ((proj blame) val)
+                    (append wrapped-accessors wrapped-mutators (list impersonator-prop:contracted ctc))))])
+           (if impersonate? 
+               (struct-wrapper impersonate-struct) 
+               (struct-wrapper chaperone-struct)))]))
+
+
+
+(define (invariantc-ho-projection impersonate?)
+  (λ (ctc)
+    (let ([orig-ctc (invariant-info-ctc ctc)]
+          [immutable (invariant-info-immutable ctc)]
+          [check (check-invariant ctc)]
+          [invariant (invariant-info-invariant ctc)]
+          [here (invariant-info-here ctc)])
+      (λ (blame)
+        (let ([indy-blame (blame-replace-negative blame here)]
+              [proj (contract-projection orig-ctc) ]
+              [raise-blame (λ (val . args) 
+                             (apply raise-blame-error blame val args))])
+          (λ (val)
+            (check val raise-blame #f)
+            (unless (invariant (((contract-projection orig-ctc) indy-blame) val))
+             (let ([kind (cond [(vector? val) 'vector]
+                               [(hash? val) 'hash]
+                               [else 'struct])])  
+               (raise-blame-error 
+                blame
+                val
+                (format "expected ~s that satisfies ~s given: ~e" kind invariant val))))
+            (build-inv-proxy ctc val invariant proj blame indy-blame impersonate?)))))))
+
+
+(define-struct (chaperone-invariantc invariant-info) ()
+  #:property prop:chaperone-contract
+  (build-chaperone-contract-property
+   #:name invariantc-name
+   #:first-order invariantc-first-order
+   #:projection (invariantc-ho-projection #f)))
+
+(define-struct (impersonator-invariantc invariant-info) ()
+  #:property prop:contract
+  (build-contract-property
+   #:name invariantc-name
+   #:first-order invariantc-first-order
+   #:projection (invariantc-ho-projection #t)))
+
+(define-syntax (invariant/c stx)
+  (syntax-case stx ()
+    [(invc arg ...)
+     (let ([args (syntax->list #'(arg ...))]
+           [this-one (gensym 'invariant-ctc)])
+       (with-syntax ([(new-arg ...) (convert-args args this-one 'invariant/c)])
+         (syntax-property
+          (syntax/loc stx
+            (invariantc new-arg ... (quote-module-name)))
+          'racket/contract:contract
+          (vector this-one (list #'invc) null))))]))
+
+(define (invariantc c inv #:struct [structid 'none] #:flat? [flat #f] #:immutable [immutable 'dont-care] here)
+  (cond
+    [(or flat
+         (and (eq? immutable #t)
+              (flat-contract? c)))
+     (make-immutable-invariantc c inv structid flat immutable here)]
+    [(chaperone-contract? c)
+     (make-chaperone-invariantc c inv structid flat immutable here)]
+    [else
+     (make-impersonator-invariantc c inv structid flat immutable here)]))