From d6d9f3ef8cbd8f6cd65e7e5d20e76fd69b01d968 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Sat, 4 Dec 2010 22:11:23 -0700
Subject: [PATCH] Adding dynamic/c and coerce/c

---
 collects/tests/unstable/contract.rkt         | 14 ++++++++-
 collects/unstable/contract.rkt               | 32 ++++++++++++++++++++
 collects/unstable/scribblings/contract.scrbl | 24 +++++++++++++++
 3 files changed, 69 insertions(+), 1 deletion(-)

diff --git a/collects/tests/unstable/contract.rkt b/collects/tests/unstable/contract.rkt
index 6f89eae80c..c3de6a9b8e 100644
--- a/collects/tests/unstable/contract.rkt
+++ b/collects/tests/unstable/contract.rkt
@@ -1,6 +1,18 @@
 #lang racket
+(require rackunit rackunit/text-ui unstable/contract "helpers.rkt" tests/eli-tester)
 
-(require rackunit rackunit/text-ui unstable/contract "helpers.rkt")
+(test
+ (let ()
+   (define p (make-parameter any/c))
+   (define c (dynamic/c string? p number?))
+   
+   (parameterize ([p (coerce/c string->number)])
+     (test
+      (contract c "123" 'pos 'neg) => 123
+      (contract c "123a" 'pos 'neg) =error> "Coercion failed"))
+   
+   (test 
+    (contract c "123" 'pos 'neg) =error> "broke")))
 
 (run-tests
  (test-suite "contract.ss"
diff --git a/collects/unstable/contract.rkt b/collects/unstable/contract.rkt
index 9a85e6b318..1be21e9a1c 100644
--- a/collects/unstable/contract.rkt
+++ b/collects/unstable/contract.rkt
@@ -1,6 +1,38 @@
 #lang racket/base
 (require racket/contract racket/dict racket/match)
 
+(define (dynamic/c pre parameter post)
+  (define pre-ctc (coerce-contract 'pre pre))
+  (define post-ctc (coerce-contract 'post post))
+  (make-contract
+   #:name (build-compound-type-name 'dynamic pre-ctc parameter post-ctc)
+   #:projection
+   (λ (b)
+     (define pre-proj ((contract-projection pre-ctc) b))
+     (define post-proj ((contract-projection post-ctc) b))
+     (λ (x)
+       (define dyn-proj
+         ((contract-projection (coerce-contract 'dynamic (parameter))) b))
+       (post-proj 
+        (dyn-proj
+         (pre-proj
+          x)))))))
+
+(define (coerce/c i->o)
+  (make-contract
+   #:name (build-compound-type-name 'coerce i->o)
+   #:projection
+   (λ (b)
+     (λ (x)
+       (or (i->o x)
+           (raise-blame-error b x "Coercion failed"))))))
+
+(provide/contract
+ [dynamic/c (-> contract? (parameter/c contract?) contract?
+                contract?)]
+ [coerce/c (-> (-> any/c any/c)
+               contract?)])
+
 (define path-element?
   (or/c path-string? (symbols 'up 'same)))
 ;; Eli: We already have a notion of "path element" which is different
diff --git a/collects/unstable/scribblings/contract.scrbl b/collects/unstable/scribblings/contract.scrbl
index a033360731..084e9aed66 100644
--- a/collects/unstable/scribblings/contract.scrbl
+++ b/collects/unstable/scribblings/contract.scrbl
@@ -222,3 +222,27 @@ immutable dictionaries (which may be passed through a constructor that involves
 efficient than the original dictionaries.
 
 }
+
+@addition[@author+email["Jay McCarthy" "jay@racket-lang.org"]]
+
+@defproc[(dynamic/c [pre contract?] [dynamic (parameter/c contract?)] [post contract?])
+         contract?]{
+Returns a contract that applies the @racket[pre] contract, then the contract dynamically bound to the @racket[dynamic] parameter, then the @racket[post] contract.
+}
+                   
+@defproc[(coerce/c [coerce (-> any/c any/c)])
+         contract?]{
+Returns a contract that applies @racket[coerce] to all values and blames the positive party if @racket[coerce] returns false. This is a light-weight way to create a contract from a simple projection.
+}
+                                    
+@defexamples[
+#:eval (eval/require 'racket/contract 'unstable/contract)
+       
+(define p (make-parameter any/c))
+(define c (dynamic/c string? p number?))
+
+(contract c "123" 'pos 'neg)
+
+(p (coerce/c string->number))
+(contract c "123" 'pos 'neg)
+(contract c "123a" 'pos 'neg)]