#lang scheme

(require srfi/19)

(define (thunk? p) (and (procedure? p) (procedure-arity-includes? p 0)))

; this setup allows for thunks and promises both to be added transparently
; to the document without endangering that document's validity.
; A document created with a promise or a thunk will become a promise itself
; when it's time to output, all thunks and promises will be
; completely evaluated, resulting in a list of _ONLY_ strings
; that the output procedure then outputs (minus the list parentheses)
; assuming no error occurs while outputting a list of strings, a
; valid document will always be produced.

(define (force-append l)
  (wait-append
   (map 
    (λ (item)
      (cond
        [(thunk? item) (encode (item))]
        [(promise? item) (encode (force item))]
        [else item]))
    l)))

(define (wait-append l)
  (if 
   (findf (λ (item) (or (thunk? item) (promise? item))) l)
   (lazy (force-append l))
   l))

(define (encode value)
  (cond
    [(keyword? value) (keyword->string value)]
    [(symbol? value) (symbol->string value)]
    [(string? value) value]
    [(bytes? value) (cdata value)] ; err...
    [(number? value) (number->string value)]
    [(path? value) (path->string value)]
    [(date? value) (date->string value)]
    [(list? value) (wait-append (map encode value))]
    [(thunk? value) value]
    [(promise? value) value]
    [(void? value) #f]
    [(null? value) #f]
    [(false? value) #f]
    [else (error "No XML encoding for" value)]))

(define (realize item)
  (cond
    [(thunk? item) (realize (item))]
    [(promise? item) (realize (force item))]
    [(list? item) (map realize (flatten item))]
    [(false? item) #""]
    [(null? item) #""]
    [(string? item) (string->bytes/utf-8 item)]
    [(bytes? item) item]
    [else (error "Invalid thingy" item)]))
      
(define (output doc [port #f])
  (let ([port (if port port (current-output-port))])
    (let loop ([doc (realize doc)])
      (if (null? doc) (void)
          (let ([item (car doc)])
            (when item
              (display (car doc) port))
            (loop (cdr doc)))))))

(define (join . values)
  (encode values))

(define start-element
  (λ (attrs values name empty?)
    (join
     "<"
     name
     (map
      (λ (a v) 
        (if v
            (list " " a "=\"" v "\"")
            #f))
      attrs values)
     (if empty? 
         (if (null? attrs)
             " />"
             "/>")
         ">"))))

(define (end-element name)
  (join "</" name ">"))

(define (cdata data)
  (join "<!--/* <![CDATA[ */\n" (bytes->string/utf-8 data) "\n/* ]]> */-->"))

(define creator
   (λ (attrs values name body)
     (if (eq? name 'lit) body
         (join
           (start-element attrs values name (null? body))
           body
           (when (not (null? body)) (end-element name))))))

(define element 
  (make-keyword-procedure 
   (λ (attrs values name . body)
     (creator attrs values name body))))

(define (named-element name)
  ; because eli thinks a tag's name is a procedure, somehow...
  (make-keyword-procedure
   (λ (attrs values . body)
     (creator attrs values name body))))

(define-syntax-rule (define-named-elements name ...)
  (begin (define name (named-element 'name)) ...))

(provide element named-element define-named-elements encode join cdata output realize)