suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Updated contracts in XML collection.

Browse Source 
svn: r17720
This commit is contained in:
Carl Eastlund 2010-01-18 18:49:39 +00:00
parent 6ac7fe78e6
commit 2a5f883a4c
2 changed files with 30 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/xml/private/structures.ss
View File

@ -58,13 +58,16 @@
(define permissive-xexprs (make-parameter #f))
(define permissive/c
(make-proj-contract 'permissive/c
(lambda (pos neg src-info name)
(simple-flat-contract
#:name 'permissive/c
#:projection
(lambda (blame)
(lambda (v)
(if (permissive-xexprs)
v
(raise-contract-error
v src-info pos name "not in permissive mode"))))
(raise-blame-error
blame v "not in permissive mode"))))
#:first-order
(lambda (v)
(permissive-xexprs))))

37
collects/xml/private/xexpr.ss
View File

@ -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