From 2a5f883a4c9c25dbe9fc64361290b10a51c9d464 Mon Sep 17 00:00:00 2001
From: Carl Eastlund <cce@racket-lang.org>
Date: Mon, 18 Jan 2010 18:49:39 +0000
Subject: [PATCH] Updated contracts in XML collection.

svn: r17720
---
 collects/xml/private/structures.ss | 21 +++++++++--------
 collects/xml/private/xexpr.ss      | 37 +++++++++++++++---------------
 2 files changed, 30 insertions(+), 28 deletions(-)

diff --git a/collects/xml/private/structures.ss b/collects/xml/private/structures.ss
index b804da49cb..24aa3b6513 100644
--- a/collects/xml/private/structures.ss
+++ b/collects/xml/private/structures.ss
@@ -58,15 +58,18 @@
 (define permissive-xexprs (make-parameter #f))
 
 (define permissive/c
-  (make-proj-contract 'permissive/c
-                      (lambda (pos neg src-info name)
-                        (lambda (v)
-                          (if (permissive-xexprs)
-                              v
-                              (raise-contract-error
-                               v src-info pos name "not in permissive mode"))))
-                      (lambda (v)
-                        (permissive-xexprs))))
+  (simple-flat-contract
+   #:name 'permissive/c
+   #:projection
+   (lambda (blame)
+     (lambda (v)
+       (if (permissive-xexprs)
+         v
+         (raise-blame-error
+          blame v "not in permissive mode"))))
+   #:first-order
+   (lambda (v)
+     (permissive-xexprs))))
 
 ; content? : TST -> Bool
 (define content/c
diff --git a/collects/xml/private/xexpr.ss b/collects/xml/private/xexpr.ss
index 61c1e83009..b88e961cec 100644
--- a/collects/xml/private/xexpr.ss
+++ b/collects/xml/private/xexpr.ss
@@ -33,31 +33,30 @@
                                (or/c (cons/c (listof (list/c symbol? string?)) (listof xexpr))
                                      (listof xexpr)))))
 
-(define xexpr/c 
-  (make-proj-contract
-   'xexpr?
-   (lambda (pos neg src-info name)
-     (lambda (val)
-       (with-handlers ([exn:invalid-xexpr?
-                        (lambda (exn)
-                          (raise-contract-error
-                           val
-                           src-info
-                           pos
-                           name
-                           "Not an Xexpr. ~a~n~nContext:~n~a"
-                           (exn-message exn)
-                           (pretty-format val)))])
-         (validate-xexpr val)
-         val)))
-   (lambda (v) #t)))
-
 (define (xexpr? x)
   (correct-xexpr? x (lambda () #t) (lambda (exn) #f)))
 
 (define (validate-xexpr x)
   (correct-xexpr? x (lambda () #t) (lambda (exn) (raise exn))))
 
+(define xexpr/c 
+  (simple-flat-contract
+   #:name 'xexpr?
+   #:projection
+   (lambda (blame)
+     (lambda (val)
+       (with-handlers ([exn:invalid-xexpr?
+                        (lambda (exn)
+                          (raise-blame-error
+                           blame
+                           val
+                           "Not an Xexpr. ~a~n~nContext:~n~a"
+                           (exn-message exn)
+                           (pretty-format val)))])
+         (validate-xexpr val)
+         val)))
+   #:first-order xexpr?))
+
 ;; ;; ;; ;; ;; ;; ;
 ;; ; xexpr? helpers