;; XML + WEB STUFF

(module web-util scheme/base
    ;; xexpr format is (<tag> <attribs> <text>)
  (require (lib "xml.ss" "xml")
           (lib "match.ss")
           (lib "url.ss" "net")
           (lib "servlet.ss" "web-server")
           (lib "pregexp.ss")
           )

  (provide (all-defined-out))


  ;; READ XML
  
  ;; translate expression to a simpler dictionary structure:
  ;; <dict>  = ((<tag> . <value>) ...)
  ;; <value> = <string> | <dict>

  ;; whitespace strings are ignored and floating non-whitespace
  ;; strings are prepended with a '$' tag.
  
  ;; http://www.prescod.net/xml/sexprs.html "The element/attribute
  ;; distinction is a constant irritant for those who wield Occam's
  ;; razor." Exactly. That's why i'm unifying.
  

  
  (define (read-website port)
    (let ((xml (read-dict port)))
      (if (eq? (car xml) 'website)
          (cdr xml)
          (raise `(not-a-website)))))

  (define (read-dict . read-args)
    (cleanup
     (xml->xexpr
      (document-element
       (apply read-xml read-args)))))

  (define (string-whitespace? str)         
    (let rest?
        ((l (string->list str)))
      (or (null? l)
          (and (char-whitespace? (car l))
               (rest? (cdr l))))))


  (define (cleanup xexpr)

    (define (raw-string str)
      (cons '$ str))
    
    (define (clean-element kar kdr)
      (if (string? kar)
          (if (string-whitespace? kar)
              kdr
              (cons (raw-string kar) kdr))
          (cons (cleanup kar) kdr)))
    
    (define (clean-attribute a)
      (cons (car a)
            (cadr a)))

    (match xexpr
           ((tag attributes . elements)
            (case tag
              ((xhtml) xexpr) ;; preserve subtree
              (else           ;; convert to dictionary
               (cons tag
                     (append
                      (map clean-attribute
                           attributes)
                      (foldr clean-element
                             '() elements))))))))


  ;; TREE DATA BASE

  (define (dict-not-found path)
    (lambda ()
      (raise-user-error
       (format "Item ~a not found in site dictionary."
               (apply
                string-append
                (map (lambda (x) (format "/~s" x))
                     (reverse path)))))))
        
  
  ;; it's easier to use paths if they are in (bottom top) format
  (define (dict-ref dict path not-found)
    (let next
        ((d dict)
         (p (reverse path)))

      (cond
       ((null? p) d)
       ((null? d) (not-found))
       ((eq? (caar d)
             (car p)) (next (cdar d)
                            (cdr p)))
       (else
        (next (cdr d) p)))))

  (define (dict? x)
    (or (null? x)
        (and
         (pair? x)
         (pair? (car x))
         (dict? (cdr x)))))

  ;; a 'db' object is a seach closure
  (define ((dict->db dict) path (not-found (dict-not-found path)))
    (ref/ls dict path not-found))

  ;; subdirectories
  (define ((db->sub db prefix) path)
    (db (append path prefix)))
    

  ;; return item or directory listing
  (define (ref/ls dict path not-found)
    (let ((thing (dict-ref dict path not-found)))
      (if (dict? thing)
          (map car thing)
          thing)))

  ;; formatters: these produce a list of elements, so they can be
  ;; appended.
  (define (str x) (format "~a" x))

  (define (list-join separator lst)
    `(,(car lst)
      ,@(foldr
         (lambda (kar kdr)
           `(,separator ,kar ,@kdr))
         '() (cdr lst))))
  

;  (define (lines lst)
;    (fold (lambda (x) x) x))
  (define red "#FF0000")
  (define blue "#0000FF")
  (define purple "#FF00FF")
  (define black "#000000")
  (define white "#FFFFFF")


  ;; PLT stuff
  (define (flatten-strings lst)
    (if (string? lst) lst
        (apply string-append
               (map flatten-strings lst))))

  ;; STYLESHEETS
  (define (css lst)
    `(#"text/css"
      ,(flatten-strings
        (map
         (match-lambda
          ((selector . propdef)
           (format "~a { ~a }\n"
                   selector
                   (flatten-strings
                    (map
                     (match-lambda
                      ((name . vals)
                       (format "~a: ~a; "
                               name
                               (flatten-strings
                                (list-join ", "
                                           (map str vals))))))
                     propdef)))))
         lst))))



)