Core implementation of new contract datatypes.

svn: r17684

collects/scheme/contract/private/blame.ss

@@ -0,0 +1,77 @@
+#lang scheme/base
+
+(require unstable/srcloc scheme/pretty)
+
+(provide blame?
+         make-blame
+         blame-source
+         blame-guilty
+         blame-innocent
+         blame-contract
+         blame-value
+         blame-positive
+         blame-negative
+         blame-swapped?
+         blame-swap
+
+         raise-blame-error
+         current-blame-format
+         (struct-out exn:fail:contract:blame))
+
+(define-struct blame [source value contract positive negative swapped?])
+
+(define (blame-guilty b)
+  (if (blame-swapped? b)
+    (blame-negative b)
+    (blame-positive b)))
+
+(define (blame-innocent b)
+  (if (blame-swapped? b)
+    (blame-positive b)
+    (blame-negative b)))
+
+(define (blame-swap b)
+  (struct-copy blame b [swapped? (not (blame-swapped? b))]))
+
+(define-struct (exn:fail:contract:blame exn:fail:contract) [object]
+  #:transparent)
+
+(define (raise-blame-error b x fmt . args)
+  (raise
+   (make-exn:fail:contract:blame
+    ((current-blame-format) b x (apply format fmt args))
+    (current-continuation-marks)
+    b)))
+
+(define (default-blame-format b x custom-message)
+  (let* ([source-message (source-location->prefix (blame-source b))]
+         [guilty-message (show (blame-guilty b))]
+         [contract-message (show (blame-contract b))]
+         [value-message (if (blame-value b)
+                          (format " on ~a" (show (blame-value b)))
+                          "")])
+    (format "~a~a broke the contract ~a~a; ~a"
+            source-message
+            guilty-message
+            contract-message
+            value-message
+            custom-message)))
+
+(define (show v)
+  (let* ([line
+          (parameterize ([pretty-print-columns 'infinity])
+            (pretty-format v))])
+    (if (< (string-length line) 30)
+      line
+      (parameterize ([pretty-print-print-line show-line-break]
+                     [pretty-print-columns 50])
+        (pretty-format v)))))
+
+(define (show-line-break line port len cols)
+  (newline port)
+  (if line
+    (begin (display "  " port) 2)
+    0))
+
+(define current-blame-format
+  (make-parameter default-blame-format))

collects/scheme/contract/private/prop.ss

@@ -0,0 +1,188 @@
+#lang scheme/base
+
+(require "blame.ss")
+
+(provide prop:contract
+         contract-struct?
+         contract-struct-name
+         contract-struct-first-order
+         contract-struct-projection
+         contract-struct-stronger?
+
+         prop:flat-contract
+         flat-contract-struct?
+
+         contract-property?
+         build-contract-property
+
+         flat-contract-property?
+         build-flat-contract-property
+
+         simple-contract
+         simple-flat-contract)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Contract Property
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-struct contract-property [ name first-order projection stronger ]
+  #:omit-define-syntaxes)
+
+(define build-contract-property
+  (build-property make-contract-property 'anonymous-contract))
+
+(define (contract-property-guard prop info)
+  (unless (contract-property? prop)
+    (raise
+     (make-exn:fail:contract
+      (format "~a: expected a contract property; got: ~e"
+              'prop:contract
+              prop)
+      (current-continuation-marks))))
+  prop)
+
+(define-values [ prop:contract contract-struct? contract-struct-property ]
+  (make-struct-type-property 'prop:contract contract-property-guard))
+
+(define (contract-struct-name c)
+  (let* ([prop (contract-struct-property c)]
+         [get-name (contract-property-name prop)]
+         [name (get-name c)])
+    name))
+
+(define (contract-struct-first-order c)
+  (let* ([prop (contract-struct-property c)]
+         [get-first-order (contract-property-first-order prop)]
+         [first-order (get-first-order c)])
+    first-order))
+
+(define (contract-struct-projection c)
+  (let* ([prop (contract-struct-property c)]
+         [get-projection (contract-property-projection prop)]
+         [projection (get-projection c)])
+    projection))
+
+(define (contract-struct-stronger? a b)
+  (let* ([prop (contract-struct-property a)]
+         [stronger (contract-property-stronger prop)])
+    (stronger a b)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Flat Contract Property
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-struct flat-contract-property [implementation]
+  #:omit-define-syntaxes)
+
+(define build-flat-contract-property
+  (build-property (compose make-flat-contract-property make-contract-property)
+                  'anonymous-flat-contract))
+
+(define (flat-contract-property-guard prop info)
+  (unless (flat-contract-property? prop)
+    (raise
+     (make-exn:fail:contract
+      (format "~a: expected a flat contract property; got: ~e"
+              'prop:flat-contract
+              prop)
+      (current-continuation-marks))))
+  prop)
+
+(define flat-contract-property->contract-property
+  flat-contract-property-implementation)
+
+(define (flat-contract-property->procedure-property prop)
+  (let* ([impl (flat-contract-property-implementation prop)]
+         [get-predicate (contract-property-first-order impl)])
+    (lambda (c x) ((get-predicate c) x))))
+
+(define-values [ prop:flat-contract
+                 flat-contract-struct?
+                 flat-contract-struct-property ]
+  (make-struct-type-property
+   'prop:flat-contract
+   flat-contract-property-guard
+   (list (cons prop:contract flat-contract-property->contract-property)
+         (cons prop:procedure flat-contract-property->procedure-property))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Friendly Property Construction
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define ((build-property mk default-name)
+         #:name [get-name #f]
+         #:first-order [get-first-order #f]
+         #:projection [get-projection #f]
+         #:stronger [stronger #f])
+
+  (let* ([get-name (or get-name (lambda (c) default-name))]
+         [get-first-order (or get-first-order get-any?)]
+         [get-projection (or get-projection
+                             (get-first-order-projection
+                              get-name get-first-order))]
+         [stronger (or stronger weakest)])
+
+    (mk get-name get-first-order get-projection stronger)))
+
+(define (get-any? c) any?)
+(define (any? x) #t)
+
+(define (weakest a b) #f)
+
+(define ((get-first-order-projection get-name get-first-order) c)
+  (first-order-projection (get-name c) (get-first-order c)))
+
+(define (((first-order-projection name first-order) b) x)
+  (if (first-order x)
+    x
+    (raise-blame-error b x "expected <~a>, given: ~e" name x)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Simple Contract Construction
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-struct simple-contract [ name first-order projection stronger ]
+  #:omit-define-syntaxes
+  #:property prop:contract
+  (make-contract-property
+   (lambda (c) (simple-contract-name c))
+   (lambda (c) (simple-contract-first-order c))
+   (lambda (c) (simple-contract-projection c))
+   (lambda (a b) ((simple-contract-stronger a) a b))))
+
+(define simple-contract
+  (build-contract make-simple-contract 'simple-contract))
+
+(define-struct simple-flat-contract [ name first-order projection stronger ]
+  #:omit-define-syntaxes
+  #:property prop:flat-contract
+  (make-flat-contract-property
+   (make-contract-property
+    (lambda (c) (simple-flat-contract-name c))
+    (lambda (c) (simple-flat-contract-first-order c))
+    (lambda (c) (simple-flat-contract-projection c))
+    (lambda (a b) ((simple-flat-contract-stronger a) a b)))))
+
+(define simple-flat-contract
+  (build-contract make-simple-flat-contract 'simple-flat-contract))
+
+(define ((build-contract mk default-name)
+         #:name [name #f]
+         #:first-order [first-order #f]
+         #:projection [projection #f]
+         #:stronger [stronger #f])
+
+  (let* ([name (or name default-name)]
+         [first-order (or first-order any?)]
+         [projection (or projection (first-order-projection name first-order))]
+         [stronger (or stronger weakest)])
+
+    (mk name first-order projection stronger)))