;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; genml.scm
;;;
;;; Copyright (c) 2000 by Boris Schaefer
;;;
;;; You may do as you please with this code as long as you do not
;;; remove this copyright notice or hold me liable for its use.
;;; Please send bug reports to the address provided in:
;;;
;;;   http://www.uncommon-sense.net/this-site/contact.html
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; some helpers
;;
(define (remove-suffix-whitespace string)
  (let ((len (string-length string)))
    (let loop ((i (- len 1)))
      (cond ((< i 0) "")
            ((char-whitespace? (string-ref string i))
             (loop (- i 1)))
            (else
             (substring string 0 (+ i 1)))))))

(define (group n list)
  (if (null? list)
      '()
      (let loop ((rest list)
                 (i 0)
                 (accumulator '())
                 (result '()))
        (if (null? rest)
            (reverse (cons (reverse accumulator) result))
            (if (< i n)
                (loop (cdr rest) (+ i 1) (cons (car rest) accumulator) result)
                (loop rest 0 '() (cons (reverse accumulator) result)))))))
  
(define (make-open-tag symbol . attributes)
  (string-append "<"
                 (symbol->string symbol)
                 (apply string-append
                        (map (lambda (attribute-value)
                               (string-append  " "
                                               (symbol->string (car attribute-value))
                                               "=\""
                                               (cadr attribute-value)
                                               "\""))
                             (group 2 attributes)))
                 ">"))

(define (make-close-tag symbol)
  (string-append "</" (symbol->string symbol) ">"))

(define newline-string (make-string 1 #\newline))

(define (combine-blocks block-list)
  (remove-suffix-whitespace
   (apply string-append
          (map (lambda blocks
                 (string-append (apply string-append blocks) newline-string))
               block-list))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; here starts the actually interesting part
;;
(define (::as tag . attributes)
  (let ((open-tag (apply make-open-tag tag attributes))
        (close-tag (make-close-tag tag)))
    (lambda blocks
      (string-append open-tag
                     (combine-blocks blocks)
                     close-tag))))

(define (::with tag . attributes)
  (let ((open-tag (apply make-open-tag tag attributes))
        (close-tag (make-close-tag tag)))
    (lambda blocks
      (string-append newline-string
                     open-tag
                     newline-string
                     (combine-blocks blocks)
                     newline-string
                     close-tag))))
       
(define (::map tag-proc block-list)
  (apply string-append
         (map (lambda (block)
                (string-append (tag-proc block) newline-string))
              block-list)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; some convenience syntax
;;
(define (symbol-strip-colon symbol)
  (let ((string (symbol->string symbol)))
    (string->symbol
     (substring string 1 (string-length string)))))

(define-syntax define-primitive-tags
  (syntax-rules (with as)
    ((define-primitive-tags
       (with with-tag1 ...)
       (as as-tag1 ...))
     (begin
       (begin (define with-tag1
                (lambda attributes
                  (apply ::with (symbol-strip-colon (quote with-tag1)) attributes)))
              ...)
       (begin (define as-tag1
                (lambda attributes
                  (apply ::as (symbol-strip-colon (quote as-tag1)) attributes)))
              ...)))
    ((define-primitive-tags
       (as as-tag1 ...)
       (with with-tag1 ...))
     (define-primitive-tags
       (with with-tag1 ...)
       (as as-tag1 ...)))
    ((define-primitive-tags
       (with with-tag1 ...))
     (define-primitive-tags
       (with with-tag1 ...)
       (as)))
    ((define-primitive-tags
       (as as-tag1 ...))
     (define-primitive-tags
       (with)
       (as as-tag1 ...)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; some example definitions
;;
(define-primitive-tags
  (with :html :head :body :ul :ol :dl :table :tr :pre)
  (as :title :h1 :h2 :h3 :h4 :h5 :h6 :a :li :dt :dd :td))

(define (:link-to dest)
  (lambda (block)
    ((:a 'href dest) block)))

(define (itemize . blocks)
  ((:ul) (::map (:li) blocks)))

(define (enumerate . blocks)
    ((:ol) (::map (:li) blocks)))

(define (simple-table . rows)
  (apply (:table) rows))

(define (row . cells)
  ((:tr) (::map (:td) cells)))

(define (multi-column . columns)
  ((:table) (apply (:tr) columns)))

(define (column . blocks)
  (apply (:td) blocks))

(define (document title . body)
  ((:html)
   ((:head)
    ((:title) title))
   (apply (:body) body)))