added unstable/prop-contract (needs docs)

2010-09-10 18:02:53 -06:00 · 2010-09-10 18:02:53 -06:00 · af4a545dc3
commit af4a545dc3
parent a3d1ff4e6c
1 changed files with 43 additions and 0 deletions
--- a/collects/unstable/prop-contract.rkt
+++ b/collects/unstable/prop-contract.rkt
@ -0,0 +1,43 @@
+#lang racket/base
+(require racket/contract/base)
+
+(define (get-stpc-proj stpc)
+  (let ([get-val-proj
+         (contract-projection
+          (struct-type-property/c-value-contract stpc))])
+    (lambda (blame)
+      (let ([val-proj (get-val-proj (blame-swap blame))])
+        (lambda (x)
+          (unless (struct-type-property? x)
+            (raise-blame-error blame x
+                               "expected struct-type-property, given ~e"
+                               x))
+          (let-values ([(nprop _pred _acc)
+                        (make-struct-type-property
+                         (wrap-name x)
+                         (lambda (val _info)
+                           (val-proj val))
+                         (list (cons x values)))])
+            nprop))))))
+
+(define (wrap-name x)
+  (string->symbol (format "wrapped-~a" (object-name x))))
+
+(struct struct-type-property/c (value-contract)
+  #:property prop:contract
+             (build-contract-property
+              #:name (lambda (c)
+                       (build-compound-type-name
+                        'struct-type-property/c
+                        (struct-type-property/c-value-contract c)))
+              #:first-order (lambda (c) struct-type-property?)
+              #:projection get-stpc-proj))
+
+(define struct-type-property/c*
+  (let ([struct-type-property/c
+         (lambda (value-contract)
+           (struct-type-property/c
+            (coerce-contract 'struct-type-property/c value-contract)))])
+    struct-type-property/c))
+
+(provide (rename-out [struct-type-property/c* struct-type-property/c]))