From 1d9b4a79b7c63943e575407746237ae3173a8377 Mon Sep 17 00:00:00 2001
From: Carl Eastlund <cce@racket-lang.org>
Date: Sun, 17 Jan 2010 03:36:56 +0000
Subject: [PATCH] Reimplemented guts based on new properties.

svn: r17686
---
 collects/scheme/contract/private/guts.ss | 414 +++++++----------------
 1 file changed, 119 insertions(+), 295 deletions(-)

diff --git a/collects/scheme/contract/private/guts.ss b/collects/scheme/contract/private/guts.ss
index cf5e50b4f6..431f0f1601 100644
--- a/collects/scheme/contract/private/guts.ss
+++ b/collects/scheme/contract/private/guts.ss
@@ -1,17 +1,14 @@
 #lang scheme/base
 
 (require "helpers.ss"
+         "blame.ss"
+         "prop.ss"
          scheme/pretty)
 
 (require (for-syntax scheme/base
                      "helpers.ss"))
 
-(provide raise-contract-error
-         guilty-party
-         exn:fail:contract2?
-         exn:fail:contract2-srclocs
-                
-         contract-violation->string
+(provide (all-from-out "blame.ss" "prop.ss")
          
          coerce-contract
          coerce-contracts
@@ -34,21 +31,13 @@
          
          contract?
          contract-name
-         contract-proc
-         make-proj-contract
+         contract-projection
          
          contract-stronger?
-         
+
+         contract-first-order
          contract-first-order-passes?
          
-         proj-prop proj-pred? proj-get
-         name-prop name-pred? name-get
-         stronger-prop stronger-pred? stronger-get
-         flat-prop flat-pred? flat-get
-         flat-proj
-         first-order-prop
-         first-order-get
-         
          ;; for opters
          check-flat-contract
          check-flat-named-contract
@@ -57,48 +46,26 @@
 (define-syntax (any stx)
   (raise-syntax-error 'any "use of 'any' outside of an arrow contract" stx))
 
-(define-values (proj-prop proj-pred? raw-proj-get) 
-  (make-struct-type-property 'contract-projection))
-(define-values (name-prop name-pred? name-get)
-  (make-struct-type-property 'contract-name))
-(define-values (stronger-prop stronger-pred? stronger-get)
-  (make-struct-type-property 'contract-stronger-than))
-(define-values (flat-prop flat-pred? flat-get)
-  (make-struct-type-property 'contract-flat))
-
-(define-values (first-order-prop first-order-pred? raw-first-order-get)
-  (make-struct-type-property 'contract-first-order))
-
-(define (first-order-get stct)
-  (cond
-    [(flat-pred? stct) (flat-get stct)]
-    [else (raw-first-order-get stct)]))
+(define (contract-first-order c)
+  (contract-struct-first-order
+   (coerce-contract 'contract-first-order-passes? c)))
 
 (define (contract-first-order-passes? c v)
-  (let ([ctc (coerce-contract 'contract-first-order-passes? c)])
-    (cond
-      [(first-order-pred? ctc) (((first-order-get ctc) ctc) v)]
-      [(flat-pred? c) (((flat-get c) c) v)]
-      [else #t])))
-
-(define (proj-get ctc)
-  (cond
-    [(proj-pred? ctc)
-     (raw-proj-get ctc)]
-    [else (error 'proj-get "unknown ~e" ctc)]))
+  ((contract-struct-first-order
+    (coerce-contract 'contract-first-order-passes? c))
+   v))
 
 ;; contract-stronger? : contract contract -> boolean
 ;; indicates if one contract is stronger (ie, likes fewer values) than another
 ;; this is not a total order.
 (define (contract-stronger? a b)
-  (let ([a-ctc (coerce-contract 'contract-stronger? a)]
-        [b-ctc (coerce-contract 'contract-stronger? b)])
-    ((stronger-get a-ctc) a-ctc b-ctc)))
+  (contract-struct-stronger? (coerce-contract 'contract-stronger? a)
+                             (coerce-contract 'contract-stronger? b)))
 
 ;; coerce-flat-contract : symbol any/c -> contract
 (define (coerce-flat-contract name x)
   (let ([ctc (coerce-contract/f x)])
-    (unless (flat-pred? ctc)
+    (unless (flat-contract-struct? ctc)
       (error name 
              "expected a flat contract or a value that can be coerced into one, got ~e"
              x))
@@ -113,7 +80,7 @@
       [(null? xs) '()]
       [else
        (let ([fst (coerce-contract/f (car xs))])
-         (unless (flat-pred? fst)
+         (unless (flat-contract-struct? fst)
            (error name 
                   "expected all of the arguments to be flat contracts, but argument ~a was not, got ~e" 
                   i
@@ -147,7 +114,7 @@
 ;; returns #f if the argument could not be coerced to a contract
 (define (coerce-contract/f x)
   (cond
-    [(proj-pred? x) x]
+    [(contract-struct? x) x]
     [(and (procedure? x) (procedure-arity-includes? x 1)) 
      (make-predicate-contract (or (object-name x) '???) x)]
     [(or (symbol? x) (boolean? x) (char? x) (null? x)) (make-eq-contract x)]
@@ -155,114 +122,6 @@
     [(number? x) (make-=-contract x)]
     [(or (regexp? x) (byte-regexp? x)) (make-regexp/c x)]
     [else #f]))
-
-(define-values (make-exn:fail:contract2 
-                exn:fail:contract2?
-                exn:fail:contract2-srclocs
-                guilty-party)
-  (let-values ([(exn:fail:contract2 
-                 make-exn:fail:contract2 
-                 exn:fail:contract2?
-                 get
-                 set)
-                (parameterize ([current-inspector (make-inspector)])
-                  (make-struct-type 'exn:fail:contract2
-                                    struct:exn:fail:contract
-                                    2
-                                    0
-                                    #f
-                                    (list (cons prop:exn:srclocs
-                                                (lambda (x)
-                                                  (exn:fail:contract2-srclocs x))))))])
-    (values
-     make-exn:fail:contract2 
-     exn:fail:contract2?
-     (lambda (x) (get x 0))
-     (lambda (x) (get x 1)))))
-
-(define (default-contract-violation->string val src-info to-blame contract-sexp msg)
-  (let ([blame-src (src-info-as-string src-info)]
-        [formatted-contract-sexp
-         (let ([one-line 
-                (let ([sp (open-output-string)])
-                  (parameterize ([pretty-print-columns 'infinity])
-                    (pretty-print contract-sexp sp)
-                    (get-output-string sp)))])
-           (if (< (string-length one-line) 30)
-               one-line
-               (let ([sp (open-output-string)])
-                 (newline sp)
-                 (parameterize ([pretty-print-print-line print-contract-liner]
-                                [pretty-print-columns 50])
-                   (pretty-print contract-sexp sp))
-                 (get-output-string sp))))]
-        [specific-blame
-         (cond
-           [(syntax? src-info)
-            (let ([datum (syntax->datum src-info)])
-              (if (symbol? datum)
-                  (format " on ~a" datum)
-                  ""))]
-           [(pair? src-info)
-            (format " on ~a" (list-ref src-info 1))]
-           [else ""])])
-    (string-append (format "~a~a broke the contract ~a~a; "
-                           blame-src
-                           (cond
-                             [(not to-blame) "<<unknown>>"]
-                             [(and (pair? to-blame)
-                                   (pair? (cdr to-blame))
-                                   (null? (cddr to-blame))
-                                   (equal? 'quote (car to-blame)))
-                              (format "'~s" (cadr to-blame))]
-                             [else (format "~s" to-blame)])
-                           formatted-contract-sexp
-                           specific-blame)
-                   msg)))
-
-(define contract-violation->string (make-parameter default-contract-violation->string))
-
-(define (raise-contract-error val src-info blame contract-sexp fmt . args)
-  (let ([blame (unpack-blame blame)])
-    (raise
-     (make-exn:fail:contract2
-      (string->immutable-string
-       ((contract-violation->string) val 
-                                     src-info 
-                                     blame
-                                     contract-sexp 
-                                     (apply format fmt args)))
-      (current-continuation-marks)
-      (cond
-        [(syntax? src-info)
-         (list (make-srcloc 
-                (syntax-source src-info)
-                (syntax-line src-info)
-                (syntax-column src-info)
-                (syntax-position src-info)
-                (syntax-span src-info)))]
-        [(srcloc? src-info) (list src-info)]
-        [else '()])
-      (unpack-blame blame)))))
-
-(define print-contract-liner
-  (let ([default (pretty-print-print-line)])
-    (λ (line port ol cols)
-      (+ (default line port ol cols)
-         (if line
-             (begin (display "  " port)
-                    2)
-             0)))))
-
-;; src-info-as-string : (union srcloc syntax #f) -> string
-(define (src-info-as-string src-info)
-  (if (or (syntax? src-info)
-          (srcloc? src-info))
-      (let ([src-loc-str (build-src-loc-string src-info)])
-        (if src-loc-str
-            (string-append src-loc-str  ": ")
-            ""))
-      ""))
        
 ;                                                      
 ;                                                      
@@ -281,86 +140,23 @@
 ;                                                      
 ;                                                      
 
-;; contract = (make-contract sexp
-;;                           (sym
-;;                            sym
-;;                            (union syntax #f)
-;;                            string
-;;                            ->
-;;                            (alpha -> alpha)))
-;; the first arg to make-contract builds the name of the contract. The
-;; path records how the violation occurs
-;;
-;; generic contract container; 
-;; the first arg to proc is a symbol representing the name of the positive blame
-;; the second arg to proc is the symbol representing the name of the negative blame
-;; the third argument to proc is the src-info.
-;; the fourth argumet is a textual representation of the original contract
-;;
-;; the argument to the result function is the value to test.
-;; (the result function is the projection)
-;;  
-
-(define (flat-proj ctc)
-  (let ([pred? ((flat-get ctc) ctc)])
-    (λ (pos neg src-info orig-str positive-position?)
-      (λ (val)
-        (if (pred? val)
-            val
-            (raise-contract-error
-             val
-             src-info
-             pos
-             orig-str
-             "expected <~a>, given: ~e"
-             ((name-get ctc) ctc)
-             val))))))
-
-(define (double-any-curried-proj ctc) double-any-curred-proj2)
-(define (double-any-curred-proj2 pos-blame neg-blame src-info orig-str positive-position?) values)
-
-
-(define-values (make-proj-contract)
-  (let ()
-    (define-struct proj-contract (the-name proj first-order-proc)
-      #:property proj-prop
-      (λ (ctc) 
-        (let ([raw-proj (proj-contract-proj ctc)])
-          (if (procedure-arity-includes? raw-proj 5)
-              raw-proj
-              (λ (pos neg src-info name positive-position?)
-                (raw-proj pos neg src-info name)))))
-      
-      #:property name-prop
-      (λ (ctc) (proj-contract-the-name ctc))
-      
-      #:property first-order-prop
-      (λ (ctc) (or (proj-contract-first-order-proc ctc)
-                   (λ (x) #t)))
-      #:property stronger-prop
-      (λ (this that) 
-        (and (proj-contract? that)
-             (procedure-closure-contents-eq?
-              (proj-contract-proj this)
-              (proj-contract-proj that)))))
-    
-    (values make-proj-contract)))
-
-(define (flat-contract-predicate x) 
-  (let ([ctc (coerce-flat-contract 'flat-contract-predicate x)])
-    ((flat-get ctc) ctc)))
+(define (flat-contract-predicate x)
+  (contract-struct-first-order
+   (coerce-flat-contract 'flat-contract-predicate x)))
 
 (define (flat-contract? x) 
   (let ([c (coerce-contract/f x)])
     (and c
-         (flat-pred? c))))
+         (flat-contract-struct? c))))
 
 (define (contract-name ctc)
-  (let ([ctc (coerce-contract 'contract-name ctc)])
-    ((name-get ctc) ctc)))
+  (contract-struct-name
+   (coerce-contract 'contract-name ctc)))
 
 (define (contract? x) (and (coerce-contract/f x) #t))
-(define (contract-proc ctc) ((proj-get ctc) ctc))
+(define (contract-projection ctc)
+  (contract-struct-projection
+   (coerce-contract 'contract-projection ctc)))
 
 (define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
 (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
@@ -385,15 +181,15 @@
        '()]
       [else (let ([sub (car subs)])
               (cond
-                [(name-pred? sub)
+                [(contract-struct? sub)
                  (let ([mk-sub-name (contract-name sub)])
                    `(,mk-sub-name ,@(loop (cdr subs))))]
                 [else `(,sub ,@(loop (cdr subs)))]))])))
 
 (define (and-proj ctc)
-  (let ([mk-pos-projs (map (λ (x) ((proj-get x) x)) (and/c-ctcs ctc))])
-    (lambda (pos neg src-info orig-str positive-position?)
-      (let ([projs (map (λ (c) (c pos neg src-info orig-str positive-position?)) mk-pos-projs)])
+  (let ([mk-pos-projs (map contract-projection (and/c-ctcs ctc))])
+    (lambda (blame)
+      (let ([projs (map (λ (c) (c blame)) mk-pos-projs)])
         (let loop ([projs (cdr projs)]
                    [proj (car projs)])
           (cond
@@ -405,23 +201,24 @@
 
 (define-struct and/c (ctcs)
   #:omit-define-syntaxes
-  #:property proj-prop and-proj
-  #:property name-prop (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc)))
-  #:property first-order-prop
-  (λ (ctc)
-    (let ([tests (map (λ (x) ((first-order-get x) x))
-                      (and/c-ctcs ctc))])
-      (λ (x) 
-        (andmap (λ (f) (f x)) tests))))
-  #:property stronger-prop
-  (λ (this that)
-    (and (and/c? that)
-         (let ([this-ctcs (and/c-ctcs this)]
-               [that-ctcs (and/c-ctcs that)])
-           (and (= (length this-ctcs) (length that-ctcs))
-                (andmap contract-stronger?
-                        this-ctcs
-                        that-ctcs))))))
+  #:property prop:contract
+  (build-contract-property
+   #:projection and-proj
+   #:name (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc)))
+   #:first-order
+   (λ (ctc)
+      (let ([tests (map contract-first-order (and/c-ctcs ctc))])
+        (λ (x) 
+           (andmap (λ (f) (f x)) tests))))
+   #:stronger
+   (λ (this that)
+      (and (and/c? that)
+           (let ([this-ctcs (and/c-ctcs this)]
+                 [that-ctcs (and/c-ctcs that)])
+             (and (= (length this-ctcs) (length that-ctcs))
+                  (andmap contract-stronger?
+                          this-ctcs
+                          that-ctcs)))))))
 
 (define (and/c . raw-fs)
   (let ([contracts (coerce-contracts 'and/c raw-fs)])
@@ -441,35 +238,42 @@
          (flat-named-contract (apply build-compound-type-name 'and/c contracts) pred))]
       [else (make-and/c contracts)])))
 
+(define (get-any-projection c) any-projection)
+(define (any-projection b) any-function)
+(define (any-function x) x)
+
+(define (get-any? c) any?)
+(define (any? x) #t)
+
 (define-struct any/c ()
   #:omit-define-syntaxes
-  #:property proj-prop double-any-curried-proj
-  #:property stronger-prop (λ (this that) (any/c? that))
-  #:property name-prop (λ (ctc) 'any/c)
-  #:property first-order-prop (λ (ctc) (λ (val) #t))
-  #:property flat-prop (λ (ctc) (λ (x) #t)))
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:projection get-any-projection
+   #:stronger (λ (this that) (any/c? that))
+   #:name (λ (ctc) 'any/c)
+   #:first-order get-any?))
 
 (define any/c (make-any/c))
 
 (define (none-curried-proj ctc)
-  (λ (pos-blame neg-blame src-info orig-str positive-position?) 
+  (λ (blame)
     (λ (val) 
-      (raise-contract-error
+      (raise-blame-error
+       blame
        val
-       src-info
-       pos-blame
-       orig-str
        "~s accepts no values, given: ~e"
        (none/c-name ctc)
        val))))
 
 (define-struct none/c (name)
   #:omit-define-syntaxes
-  #:property proj-prop none-curried-proj
-  #:property stronger-prop (λ (this that) #t)
-  #:property name-prop (λ (ctc) (none/c-name ctc))
-  #:property first-order-prop (λ (ctc) (λ (val) #f))
-  #:property flat-prop (λ (ctc) (λ (x) #f)))
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:projection none-curried-proj
+   #:stronger (λ (this that) #t)
+   #:name (λ (ctc) (none/c-name ctc))
+   #:first-order (λ (ctc) (λ (val) #f))))
 
 (define none/c (make-none/c 'none/c))
 
@@ -495,43 +299,63 @@
 ;                                                                                                                 
 
 (define-struct eq-contract (val)
-  #:property proj-prop flat-proj
-  #:property flat-prop (λ (ctc) (λ (x) (eq? (eq-contract-val ctc) x)))
-  #:property name-prop (λ (ctc) 
-                         (if (symbol? (eq-contract-val ctc))
-                             `',(eq-contract-val ctc)
-                             (eq-contract-val ctc)))
-  #:property stronger-prop (λ (this that) (and (eq-contract? that) (eq? (eq-contract-val this) (eq-contract-val that)))))
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:first-order (λ (ctc) (λ (x) (eq? (eq-contract-val ctc) x)))
+   #:name
+   (λ (ctc) 
+      (if (symbol? (eq-contract-val ctc))
+        `',(eq-contract-val ctc)
+        (eq-contract-val ctc)))
+   #:stronger
+   (λ (this that)
+      (and (eq-contract? that)
+           (eq? (eq-contract-val this) (eq-contract-val that))))))
 
 (define-struct equal-contract (val)
-  #:property proj-prop flat-proj
-  #:property flat-prop (λ (ctc) (λ (x) (equal? (equal-contract-val ctc) x)))
-  #:property name-prop (λ (ctc) (equal-contract-val ctc))
-  #:property stronger-prop (λ (this that) (and (equal-contract? that) (equal? (equal-contract-val this) (equal-contract-val that)))))
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:first-order (λ (ctc) (λ (x) (equal? (equal-contract-val ctc) x)))
+   #:name (λ (ctc) (equal-contract-val ctc))
+   #:stronger
+   (λ (this that)
+      (and (equal-contract? that)
+           (equal? (equal-contract-val this) (equal-contract-val that))))))
 
 (define-struct =-contract (val)
-  #:property proj-prop flat-proj
-  #:property flat-prop (λ (ctc) (λ (x) (and (number? x) (= (=-contract-val ctc) x))))
-  #:property name-prop (λ (ctc) (=-contract-val ctc))
-  #:property stronger-prop (λ (this that) (and (=-contract? that) (= (=-contract-val this) (=-contract-val that)))))
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:first-order (λ (ctc) (λ (x) (and (number? x) (= (=-contract-val ctc) x))))
+   #:name (λ (ctc) (=-contract-val ctc))
+   #:stronger
+   (λ (this that)
+      (and (=-contract? that)
+           (= (=-contract-val this) (=-contract-val that))))))
 
 (define-struct regexp/c (reg)
-  #:property proj-prop flat-proj
-  #:property flat-prop (λ (ctc) (λ (x) (and (or (string? x) (bytes? x))
-                                            (regexp-match (regexp/c-reg ctc) x)
-                                            #t)))
-  #:property name-prop (λ (ctc) (regexp/c-reg ctc))
-  #:property stronger-prop (λ (this that) (and (regexp/c? that) (eq? (regexp/c-reg this) (regexp/c-reg that)))))
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:first-order
+   (λ (ctc)
+      (λ (x)
+         (and (or (string? x) (bytes? x))
+              (regexp-match (regexp/c-reg ctc) x)
+              #t)))
+   #:name (λ (ctc) (regexp/c-reg ctc))
+   #:stronger
+   (λ (this that)
+      (and (regexp/c? that) (eq? (regexp/c-reg this) (regexp/c-reg that))))))
 
 
 (define-struct predicate-contract (name pred)
-  #:property proj-prop flat-proj
-  #:property stronger-prop
-  (λ (this that) 
-    (and (predicate-contract? that)
-         (procedure-closure-contents-eq? (predicate-contract-pred this)
-                                         (predicate-contract-pred that))))
-  #:property name-prop (λ (ctc) (predicate-contract-name ctc))
-  #:property flat-prop (λ (ctc) (predicate-contract-pred ctc)))
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:stronger
+   (λ (this that) 
+      (and (predicate-contract? that)
+           (procedure-closure-contents-eq? (predicate-contract-pred this)
+                                           (predicate-contract-pred that))))
+   #:name (λ (ctc) (predicate-contract-name ctc))
+   #:first-order (λ (ctc) (predicate-contract-pred ctc))))
 
 (define (build-flat-contract name pred) (make-predicate-contract name pred))