; copyright by Paul Graunke June 2000 AD
(require (lib "pretty.ss")
         (lib "date.ss")
         (lib "list.ss")
         (lib "etc.ss"))

; date-string : -> String
(define (date-string) (date->string (seconds->date (current-seconds)) 'seconds-please))

(define html-spec (call-with-input-file (build-path (collection-path "html") "html-spec") read))

(define (empty-name? x) (null? (cdr x)))

(define empty-names
  (apply append (map car (filter empty-name? html-spec))))

(define non-empty-names 
  (apply append (map car (filter (compose not empty-name?) html-spec))))

; generate-structs : -> Void
(define (generate-structs)
  (let ([file (build-path (collection-path "html") "html-structs.ss")])
    (printf "building ~a~n" file)
    (call-with-output-file file
      (lambda (out)
        (fprintf out "; This code was machine generated by generate-code.ss ~a~n" (date-string))
        (for-each
         (lambda (x) (pretty-print x  out))
         (append
          (list
           '(define-struct html-element (attributes))
           `(define-struct (html-full html-element) (content)))
          (map (lambda (x) `(define-struct (,x html-full) ()))
               non-empty-names)
          (map (lambda (x)
                 `(define-struct (,x html-element) ()))
               empty-names))))
      'text 'truncate)))

; generate-case : -> Void
(define (generate-case)
  (let ([file (build-path (collection-path "html") "case.ss")])
    (printf "building ~a~n" file)
    (call-with-output-file file
      (lambda (out)
        (fprintf out ";This file was generated by genrate-code.ss on ~a~n" (date-string))
        (fprintf out "~n; xml-single-content->html : Content (listof Html-content) -> (listof Html-content)~n")
        (pretty-print
         `(define (xml-single-content->html x acc)
            (cond
              [(element? x)
               (case (element-name x)
                 ,@(append
                    (map (lambda (name)
                           `[(,name) (cons (,(string->symbol (string-append "make-" (symbol->string name)))
                                            (element-attributes x))
                                           acc)])
                         empty-names)
                    (map (lambda (name)
                           `[(,name) (cons (,(string->symbol (string-append "make-" (symbol->string name)))
                                            (element-attributes x)
                                            (xml-contents->html (element-content x)))
                                           acc)])
                         non-empty-names))
                 [else acc])]
              [(or (pcdata? x) (entity? x)) (cons x acc)]
              [else acc]))
         out))
      'truncate 'text)))

(generate-structs)
(generate-case)