sunet/scheme/xml/structures.scm

; Location = (make-location Nat Nat) | Symbol
(define-record-type location :location
  (make-location line char offset)
  location?
  (line location-line)
  (char location-char)
  (offset location-offset))

;; Source ::= (make-source Location Location)
(define-record-type source :source
  (make-source start stop)
  really-source?
  (start really-source-start)
  (stop really-source-stop))
 
(define (source-start obj)
  (cond ((element? obj) (element-start obj))
	((attribute? obj) (attribute-start obj))
	((pcdata? obj) (pcdata-start obj))
	((entity? obj) (entity-start obj))
	((pi? obj) (pi-start obj))
	((start-tag? obj) (start-tag-start obj))
	((end-tag? obj) (end-tag-start obj))
	(else (really-source-start obj))))

(define (source-stop obj)
  (cond ((element? obj) (element-stop obj))
	((attribute? obj) (attribute-stop obj))
	((pcdata? obj) (pcdata-stop obj))
	((entity? obj) (entity-stop obj))
	((pi? obj) (pi-stop obj))
	((start-tag? obj) (start-tag-stop obj))
	((end-tag? obj) (end-tag-stop obj))
	(else (really-source-stop obj))))

(define (does-any-satisfy? preds obj)
    (if (null? preds)
	#f
	(or ((car preds) obj) (does-any-satisfy? (cdr preds) obj))))

(define (source? obj)
  (does-any-satisfy? (list really-source? element? attribute? pcdata? 
			   entity? pi? start-tag? end-tag?)
		     obj))

;; Document ::= (make-document Prolog Element (listof Misc))
(define-record-type document :document
  (make-document prolog element misc)
  document?
  (prolog document-prolog)
  (element document-element)
  (misc document-misc))

      ; Prolog = (make-prolog (listof Misc) Document-type [Misc ...])
      ; The Misc items after the Document-type are optional arguments to maintain
      ; backward compatability with older versions of the XML library.
      ;(define-struct prolog (misc dtd misc2))

(define-record-type prolog :prolog
  (really-make-prolog misc dtd misc2)
  prolog?
  (misc prolog-misc)
  (dtd prolog-dtd)
  (misc2 prolog-misc2))

(define (make-prolog misc dtd . misc2)
  (really-make-prolog misc dtd misc2))

;;; Document-type = (make-document-type sym External-dtd #f)
;;;               | #f

(define-record-type document-type :document-type
  (make-document-type name external inlined)
  really-document-type?
  (name document-type-name)
  (external document-type-external)
  (inlined document-type-inlined))

;;; External-dtd = (make-external-dtd/public str str)
;;;              | (make-external-dtd/system str)
;;;              | #f
(define-record-type external-dtd :external-dtd
  (make-external-dtd system)
  really-external-dtd?
  (system really-external-dtd-system))

(define (external-dtd-system external-dtd)
  (cond ((really-external-dtd? external-dtd)
	 (really-external-dtd-system external-dtd))
	((external-dtd/public? external-dtd)
	 (external-dtd/public-system external-dtd))
	((external-dtd/system? external-dtd)
	 (external-dtd/system-system external-dtd))
	(else (error "bottom of external-dtd-system" external-dtd))))

(define (external-dtd? obj)
  (does-any-satisfy? (list really-external-dtd? external-dtd/public? 
			   external-dtd/system?)
		     obj))

(define-record-type external-dtd/public :external-dtd/public
  (make-external-dtd/public system public)
  external-dtd/public?
  (system external-dtd/public-system)
  (public external-dtd/public-public))

(define-record-type external-dtd/system :external-dtd/system
  (make-external-dtd/system system)
  external-dtd/system?
  (system external-dtd/system-system))


;; Element ::= (make-element Location Location Symbol (listof Attribute) (listof Content))
(define-record-type element :element
  (make-element start stop name attributes content)
  element?
  (start element-start)
  (stop element-stop)
  (name element-name)
  (attributes element-attributes)
  (content element-content))

;; Attribute ::= (make-attribute Location Location Symbol String)
(define-record-type attribute :attribute
  (make-attribute start stop name value)
  attribute?
  (start attribute-start)
  (stop attribute-stop)
  (name attribute-name)
  (value attribute-value))

;; Pcdata ::= (make-pcdata Location Location String)
(define-record-type pcdata :pcdata
  (make-pcdata start stop string)
  pcdata?
  (start pcdata-start)
  (stop pcdata-stop)
  (string pcdata-string))

;; Content ::= Pcdata  
;;          |  Element
;;          |  Entity
;;          |  Misc

;; Misc ::= Comment
;;       |  Processing-instruction

;; Entity ::= (make-entity Location Location (U Nat Symbol))
(define-record-type entity :entity
  (make-entity start stop text)
  entity?
  (start entity-start)
  (stop entity-stop)
  (text entity-text))

;; Processing-instruction ::= (make-pi Location Location String (list String))
;; also represents XMLDecl
(define-record-type pi :pi
  (make-pi start stop target-name instruction)
  pi?
  (start pi-start)
  (stop pi-stop)
  (target-name pi-target-name)
  (instruction pi-instruction))

;; Comment ::= (make-comment String)
(define-record-type comment :comment
  (make-comment text)
  comment?
  (text comment-text))

;; content? : TST -> Bool
(define (content? x)
  (or (pcdata? x) (element? x) (entity? x) (comment? x) (pi? x)))


;;; moved here from reader as it inherits from source
;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute))
(define-record-type start-tag :start-tag
  (make-start-tag start stop name attrs)
  start-tag?
  (start start-tag-start)
  (stop start-tag-stop)
  (name start-tag-name)
  (attrs start-tag-attrs))


;; End-tag ::= (make-end-tag Location Location Symbol)
(define-record-type end-tag :end-tag
  (make-end-tag start stop name)
  end-tag?
  (start end-tag-start)
  (stop end-tag-stop)
  (name end-tag-name))