#lang scheme/base

(require srfi/19
         net/url
         scheme/promise
         scheme/bool
         scheme/list)

(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) (bytes->string/utf-8 value)] ; err...
    [(number? value) (number->string 
                      (if (exact? value)
                          (exact->inexact value)
                          value))]
    [(path? value) (path->string value)]
    [(date? value) (date->string value)]
    [(list? value) (wait-append (map encode value))]
    [(thunk? value) value]
    [(promise? value) value]
    ((thingy? value) (encode ((thingy-encode value) (encode (thingy-value value)))))
    ((url? value) (url->string value))
    [(void? value) #f]
    [(null? value) #f]
    [(false? value) #f]
    [(eq? value #t) "#t"]
    [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 ((doc (realize doc)))
      (if (null? doc) (void)
          (for-each write-bytes 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)
             " />\n"
             "/>\n")
         ">"))))

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

; specially encoded... thingies
(define-struct thingy (type encode value) #:transparent)

(define-syntax-rule (define-thingy id encode)
  (define (id . value) (make-thingy 'id encode value)))

(define-thingy cdata 
  (λ (value)
    (list "<![CDATA[" value "]]>")))
(define-thingy comment
  (λ (value)
    (list "<!--" value "-->")))

(define (escape s)
  (foldl
   (λ (pair result )
     (regexp-replace* (car pair) result (format "\\&~a;" (cdr pair))))
   s
   '((#rx"&" . amp)
     (#rx"<" . lt)
     (#rx">" . gt))))

(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 escape
         element named-element define-named-elements encode join output realize
         define-thingy
         cdata comment)