add `xml/xexpr'

Exports `xexpr?' and `xexpr/c' without dependencies on the rest of
the `xml' library.

collects/xml/private/core.rkt

@@ -0,0 +1,36 @@
+#lang racket/base
+(require racket/contract/base)
+
+;; Core structures needed for `xml/xexpr'
+
+(provide (all-defined-out))
+
+; permissive-xexprs : parameter bool
+(define permissive-xexprs (make-parameter #f))
+
+; Source = (make-source Location Location)
+(define-struct source (start stop) #:transparent)
+
+; Comment = (make-comment String)
+(define-struct comment (text) #:transparent)
+
+; Processing-instruction = (make-p-i Location Location String String)
+; also represents XMLDecl
+(define-struct (p-i source) (target-name instruction) #:transparent)
+
+; Pcdata = (make-pcdata Location Location String)
+(define-struct (pcdata source) (string) #:transparent)
+
+; Cdata = (make-cdata Location Location String)
+(define-struct (cdata source) (string) #:transparent)
+
+; Section 2.2 of XML 1.1
+; (XML 1.0 is slightly different and looks less restrictive)
+(define (valid-char? i)
+  (and (exact-nonnegative-integer? i)
+       (or (= i #x9)
+           (= i #xA)
+           (= i #xD)
+           (<= #x20 i #xD7FF)
+           (<= #xE000 i #xFFFD)
+           (<= #x10000 i #x10FFFF))))

collects/xml/private/structures.rkt

@@ -1,12 +1,10 @@
 #lang racket/base
-(require racket/contract)
+(require "core.rkt"
+         racket/contract)
 
 ; Location = (make-location Nat Nat Nat) | Symbol
 (define-struct location (line char offset) #:transparent)
 
-; Source = (make-source Location Location)
-(define-struct source (start stop) #:transparent)
-
 ; Document = (make-document Prolog Element (listof Misc))
 (define-struct document (prolog element misc) #:transparent)
 
@@ -30,12 +28,6 @@
 ; Attribute = (make-attribute Location Location Symbol String)
 (define-struct (attribute source) (name value) #:transparent)
 
-; Pcdata = (make-pcdata Location Location String)
-(define-struct (pcdata source) (string) #:transparent)
-
-; Cdata = (make-cdata Location Location String)
-(define-struct (cdata source) (string) #:transparent)
-
 ; Content = Pcdata  
 ;         |  Element
 ;         |  Entity
@@ -45,30 +37,9 @@
 ; Misc = Comment
 ;      |  Processing-instruction
 
-; Section 2.2 of XML 1.1
-; (XML 1.0 is slightly different and looks less restrictive)
-(define (valid-char? i)
-  (and (exact-nonnegative-integer? i)
-       (or (= i #x9)
-           (= i #xA)
-           (= i #xD)
-           (<= #x20 i #xD7FF)
-           (<= #xE000 i #xFFFD)
-           (<= #x10000 i #x10FFFF))))
-
 ; Entity = (make-entity Location Location (U Nat Symbol))
 (define-struct (entity source) (text) #:transparent)
 
-; Processing-instruction = (make-p-i Location Location String String)
-; also represents XMLDecl
-(define-struct (p-i source) (target-name instruction) #:transparent)
-
-; Comment = (make-comment String)
-(define-struct comment (text) #:transparent)
-
-; permissive-xexprs : parameter bool
-(define permissive-xexprs (make-parameter #f))
-
 (define permissive/c
   (make-contract
    #:name 'permissive/c

collects/xml/private/xexpr-core.rkt

@@ -0,0 +1,147 @@
+#lang racket/base
+(require racket/list
+         racket/contract/base
+         racket/contract/combinator
+         racket/pretty
+         "core.rkt")
+
+
+(provide
+ (contract-out
+  [xexpr/c contract?]
+  [xexpr? (any/c . -> . boolean?)]
+  [validate-xexpr (any/c . -> . (one-of/c #t))]
+  [correct-xexpr? (any/c (-> any/c) (exn:invalid-xexpr? . -> . any/c) . -> . any/c)])
+ (struct-out exn:invalid-xexpr))
+
+;; Xexpr ::= String
+;;        |  (list* Symbol (listof Attribute-srep) (listof Xexpr))
+;;        |  (cons Symbol (listof Xexpr))
+;;        |  Symbol
+;;        |  Nat (WFC: Valid Char)
+;;        |  Comment
+;;        |  Processing-instruction
+;;        |  Cdata
+;; Attribute-srep ::= (list Symbol String)
+
+;; sorting is no longer necessary, since xt3d uses xml->zxexpr, which sorts.
+
+(define xexpr-datum/c
+  (or/c string? symbol? valid-char?
+        comment? p-i? cdata? pcdata?))
+
+(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 
+  (make-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
+
+(define-struct (exn:invalid-xexpr exn:fail) (code))
+
+;; correct-xexpr? : any (-> a) (exn -> a) -> a
+(define (correct-xexpr? x true false)
+  (cond
+    ((string? x) (true))
+    ((symbol? x) (true))
+    ((valid-char? x) (true))
+    ((comment? x) (true))
+    ((p-i? x) (true))
+    ((cdata? x) (true))
+    ((pcdata? x) (true))
+    ((list? x)
+     (or (null? x)
+         (if (symbol? (car x))
+             (if (has-attribute? x)
+                 (and (attribute-pairs? (cadr x) true false)
+                      (andmap (lambda (part)
+                                (correct-xexpr? part true false))
+                              (cddr x))
+                      (true))
+                 (andmap (lambda (part)
+                           (correct-xexpr? part true false))
+                         (cdr x)))
+             (false (make-exn:invalid-xexpr
+                     (format
+                      "Expected a symbol as the element name, given ~s"
+                      (car x))
+                     (current-continuation-marks)
+                     x)))))
+    [(permissive-xexprs) (true)]
+    (else (false
+           (make-exn:invalid-xexpr
+            (format (string-append
+                     "Expected a string, symbol, valid numeric entity, comment, "
+                     "processing instruction, or list, given ~s")
+                    x)
+            (current-continuation-marks)
+            x)))))
+
+;; has-attribute? : List -> Boolean
+;; True if the Xexpr provided has an attribute list.
+(define (has-attribute? x)
+  (and (> (length x) 1)
+       (list? (cadr x))
+       (andmap (lambda (attr)
+                 (pair? attr))
+               (cadr x))))
+
+;; attribute-pairs? : List (-> a) (exn -> a) -> a
+;; True if the list is a list of pairs.
+(define (attribute-pairs? attrs true false)
+  (if (null? attrs)
+      (true)
+      (let ((attr (car attrs)))
+        (if (pair? attr)
+            (and (attribute-symbol-string? attr true false)
+                 (attribute-pairs? (cdr attrs) true false )
+                 (true))
+            (false
+             (make-exn:invalid-xexpr
+              (format "Expected an attribute pair, given ~s" attr)
+              (current-continuation-marks)
+              attr))))))
+
+;; attribute-symbol-string? : List (-> a) (exn -> a) -> a
+;; True if the list is a list of String,Symbol pairs.
+(define (attribute-symbol-string? attr true false)
+  (if (symbol? (car attr))
+      (if (pair? (cdr attr))
+          (if (or (string? (cadr attr))
+                  (permissive-xexprs))
+              (true)
+              (false (make-exn:invalid-xexpr
+                      (format "Expected an attribute value string, given ~v" (cadr attr))
+                      (current-continuation-marks)
+                      (cadr attr))))
+          (false (make-exn:invalid-xexpr
+                  (format "Expected an attribute value string for attribute ~s, given nothing" attr)
+                  (current-continuation-marks)
+                  attr)))
+      (false (make-exn:invalid-xexpr
+              (format "Expected an attribute symbol, given ~s" (car attr))
+              (current-continuation-marks)
+              (cadr attr)))))
+
+;; ; end xexpr? helpers
+;; ;; ;; ;; ;; ;; ;; ;;

collects/xml/private/xexpr.rkt

@@ -2,20 +2,11 @@
 (require racket/pretty
          racket/list
          racket/contract
+         "xexpr-core.rkt"
          "structures.rkt"
          "reader.rkt"
          "writer.rkt")
 
-;; Xexpr ::= String
-;;        |  (list* Symbol (listof Attribute-srep) (listof Xexpr))
-;;        |  (cons Symbol (listof Xexpr))
-;;        |  Symbol
-;;        |  Nat (WFC: Valid Char)
-;;        |  Comment
-;;        |  Processing-instruction
-;;        |  Cdata
-;; Attribute-srep ::= (list Symbol String)
-
 ;; sorting is no longer necessary, since xt3d uses xml->zxexpr, which sorts.
 
 ;; assoc-sort : (listof (list Symbol a)) -> (listof (list Symbol a))
@@ -24,134 +15,6 @@
 
 (define xexpr-drop-empty-attributes (make-parameter #f))
 
-(define xexpr-datum/c
-  (or/c string? symbol? valid-char?
-        comment? p-i? cdata? pcdata?))
-
-#;(define xexpr/c
-    (flat-rec-contract xexpr
-                       xexpr-datum/c
-                       (cons/c symbol?
-                               (or/c (cons/c (listof (list/c symbol? string?)) (listof xexpr))
-                                     (listof xexpr)))))
-
-(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 
-  (make-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
-
-(define-struct (exn:invalid-xexpr exn:fail) (code))
-
-;; correct-xexpr? : any (-> a) (exn -> a) -> a
-(define (correct-xexpr? x true false)
-  (cond
-    ((string? x) (true))
-    ((symbol? x) (true))
-    ((valid-char? x) (true))
-    ((comment? x) (true))
-    ((p-i? x) (true))
-    ((cdata? x) (true))
-    ((pcdata? x) (true))
-    ((list? x)
-     (or (null? x)
-         (if (symbol? (car x))
-             (if (has-attribute? x)
-                 (and (attribute-pairs? (cadr x) true false)
-                      (andmap (lambda (part)
-                                (correct-xexpr? part true false))
-                              (cddr x))
-                      (true))
-                 (andmap (lambda (part)
-                           (correct-xexpr? part true false))
-                         (cdr x)))
-             (false (make-exn:invalid-xexpr
-                     (format
-                      "Expected a symbol as the element name, given ~s"
-                      (car x))
-                     (current-continuation-marks)
-                     x)))))
-    [(permissive-xexprs) (true)]
-    (else (false
-           (make-exn:invalid-xexpr
-            (format (string-append
-                     "Expected a string, symbol, valid numeric entity, comment, "
-                     "processing instruction, or list, given ~s")
-                    x)
-            (current-continuation-marks)
-            x)))))
-
-;; has-attribute? : List -> Boolean
-;; True if the Xexpr provided has an attribute list.
-(define (has-attribute? x)
-  (and (> (length x) 1)
-       (list? (cadr x))
-       (andmap (lambda (attr)
-                 (pair? attr))
-               (cadr x))))
-
-;; attribute-pairs? : List (-> a) (exn -> a) -> a
-;; True if the list is a list of pairs.
-(define (attribute-pairs? attrs true false)
-  (if (null? attrs)
-      (true)
-      (let ((attr (car attrs)))
-        (if (pair? attr)
-            (and (attribute-symbol-string? attr true false)
-                 (attribute-pairs? (cdr attrs) true false )
-                 (true))
-            (false
-             (make-exn:invalid-xexpr
-              (format "Expected an attribute pair, given ~s" attr)
-              (current-continuation-marks)
-              attr))))))
-
-;; attribute-symbol-string? : List (-> a) (exn -> a) -> a
-;; True if the list is a list of String,Symbol pairs.
-(define (attribute-symbol-string? attr true false)
-  (if (symbol? (car attr))
-      (if (pair? (cdr attr))
-          (if (or (string? (cadr attr))
-                  (permissive-xexprs))
-              (true)
-              (false (make-exn:invalid-xexpr
-                      (format "Expected an attribute value string, given ~v" (cadr attr))
-                      (current-continuation-marks)
-                      (cadr attr))))
-          (false (make-exn:invalid-xexpr
-                  (format "Expected an attribute value string for attribute ~s, given nothing" attr)
-                  (current-continuation-marks)
-                  attr)))
-      (false (make-exn:invalid-xexpr
-              (format "Expected an attribute symbol, given ~s" (car attr))
-              (current-continuation-marks)
-              (cadr attr)))))
-
-;; ; end xexpr? helpers
-;; ;; ;; ;; ;; ;; ;; ;;
-
-
 ; : (a -> bool) tst -> bool
 ; To check if l is a (listof p?)
 ; Don't use (and (list? l) (andmap p? l)) because l may be improper.
@@ -241,19 +104,20 @@
 (define (bcompose f g)
   (lambda (x y) (f (g x) (g y))))
 
+(provide xexpr? 
+         validate-xexpr
+         correct-xexpr?
+         xexpr/c)
+
 (provide/contract
  [exn:invalid-xexpr? (any/c . -> . boolean?)]
  [exn:invalid-xexpr-code (exn:invalid-xexpr? . -> . any/c)]
- [xexpr/c contract?]
- [xexpr? (any/c . -> . boolean?)]
  [string->xexpr (string? . -> . xexpr/c)]
  [xexpr->string (xexpr/c . -> . string?)]
  [xml->xexpr (content/c . -> . xexpr/c)]
  [xexpr->xml (xexpr/c . -> . content/c)]
  [xexpr-drop-empty-attributes (parameter/c boolean?)]
- [write-xexpr (->* (xexpr/c) (output-port?) void)] 
+ [write-xexpr (->* (xexpr/c) (output-port?) void)] )
- [validate-xexpr (any/c . -> . (one-of/c #t))]
- [correct-xexpr? (any/c (-> any/c) (exn:invalid-xexpr? . -> . any/c) . -> . any/c)])
 
 (define (write-xexpr x [out (current-output-port)])
   (cond

collects/xml/xexpr.rkt

@@ -0,0 +1,8 @@
+#lang racket/base
+(require "private/xexpr-core.rkt")
+
+
+(provide xexpr/c
+         xexpr?
+         validate-xexpr
+         correct-xexpr?)

collects/xml/xml.scrbl

@@ -18,7 +18,7 @@
 
 @author["Paul Graunke and Jay McCarthy"]
 
-@defmodule[xml]
+@defmodule[xml #:use-sources (xml/private/xexpr-core)]
 
 The @racketmodname[xml] library provides functions for parsing and
 generating XML. XML can be represented as an instance of the
@@ -181,6 +181,16 @@ and a @racket[_misc] is an instance of the @racket[comment] or
 
 @; ----------------------------------------------------------------------
 
+@section{X-expression Predicate and Contract}
+
+@defmodule[xml/xexpr]
+
+The @racketmodname[xml/xexpr] library provides just @racket[xexpr/c],
+@racket[xexpr?], @racket[correct-xexpr?], and @racket[validate-xexpr]
+from @racketmodname[xml] with minimal dependencies.
+
+@; ----------------------------------------------------------------------
+
 @section{Reading and Writing XML}
 
 @defproc[(read-xml [in input-port? (current-input-port)]) document?]{