; Generating XML

(define (generate-XML Content)
  (let*
      ;; Universal transformation rules. Work for every XML,
      ;; present and future
   ((universal-conversion-rules
     `((@
	((*default*       ; local override for attributes
	  . ,(lambda (attr-key . value) (enattr attr-key value))))
	. ,(lambda (trigger . value) (list '@ value)))
       (*default* . ,(lambda (tag . elems) (entag tag elems)))
       (*text* . ,(lambda (trigger str) 
		    (if (string? str) (string->goodHTML str) str)))
       ))
    )

  (post-order Content
   `(
     ,@universal-conversion-rules

     (begin
      . ,(lambda (tag . body)
	   (list "<?xml version=\"1.0\" ?>" nl
		  body
		  nl)))
 
     ; Description of the Resources
     ; A resource is declared by a SXML element
     ;	(Resource name title date version)
     ; where name is a filename for a document resource,
     ; name of an element or an attribute
     ; The Resource element by itself does not generate any
     ; XML. It is used as a container of information about the
     ; resource. This information is when evaluating Resource-ref
     ; and Resource-descr elements.

     (Resource
      . ,(lambda (tag name title date version)
	   '()))		; null expansion


     
     (Described-by	; (Described-by res-name) 
      . ,(lambda (tag name)	; A higher-order tag
	   `(DescribedBy
	     (Resource-ref ,name))))

     (DescribeDoc	; Describe a document resource
      . ,(lambda (tag name)
	   (generate-XML
	    `(AddTransaction
	      (Resource-descr ,name)
	      (InformationResourceTypeDocument
	       (InformationResourceLocation ,name)
	       )))
	   ))

     (DescribeSample	; Describe an XML sample doc
      . ,(lambda (tag name . relations)
	   (generate-XML
	    `(AddTransaction
	      (Resource-descr ,name)
	      (InformationResourceTypeXMLSample
	       (InformationResourceLocation ,name)
	       (Relationships
		,@relations))))
	   ))

     (DescribeDTD	; Describe a DTD
      . ,(lambda (tag name . relations)
	   (generate-XML
	    `(AddTransaction
	      (Resource-descr ,name)
	      (InformationResourceTypeXMLschema
	       (@ (schemaType "DTD"))
	       (InformationResourceLocation ,name)
	       (Relationships
		,@relations))))
	   ))

     (XMLElement	; Describe an XML element
      . ,(lambda (tag name content descr-by . attlist)
	   (generate-XML
	    `(AddTransaction
	      (Resource-descr ,name)
	      (InformationResourceTypeXMLElement
	       ,content
	       (Relationships
		,@attlist
		(DescribedBy
		 (Resource-ref ,descr-by))
		))))))

     (XMLSpecFor
      . ,(lambda (tag name lit-version)
	   (list 'IsXMLSpecFor
	    '(Namespace "MET")
	    (list 'InformationResourceName name)
	    (list 'InformationResourceVersion lit-version))))

     ; Describe datatypes of elements and attributes
     (DTString		; A string datatype
      . ,(lambda (tag length)
	   `(DataTypeString (StringLength ,length))))

     (DTInt		; An int datatype
      . ,(lambda (tag length unit)
	   `(DataTypeInteger (IntegerLength ,length)
			     (IntegerUnitMeasure ,unit))))

     (DTFloat		; A floating-point datatype
      . ,(lambda (tag length precision unit)
	   `(DataTypeFloat (FloatLength ,length)
			   (FloatPrecision ,precision)
			   (FloatUnitMeasure ,unit))))


     (DTContainer	; A container of other elements
      . ,(lambda (tag . elem-names)
	   (cons 'DataTypeContainer
		 (map 
		  (lambda (elem-name) 
		    (list 'Contains
			  (list 'Resource-ref elem-name)))
		  elem-names))))

     (Attlist
      . ,(lambda (tag . attr-names)
	   (map (lambda (attr-name) 
		  (list 'IsQualifiedByAttribute
			(list 'Resource-ref attr-name)))
	   attr-names)))


     (XMLAttr	; default-value may be #f if omitted
      . ,(lambda (tag name content default-value descr-by)
	   (generate-XML
	    `(AddTransaction
	      (Resource-descr ,name)
	      (InformationResourceTypeXMLAttribute
	       ,content
	       ,(and default-value (list 'DefaultValue default-value))
	       (Relationships
		(DescribedBy
		 (Resource-ref ,descr-by))
		))))))

  ))))


;(SRV:send-reply (generate-XML (read (current-input-port))))