;escape character -*- Scheme -*-

(import (chicken file) srfi-1)

(set! mistie-escape-char #\\)

(define h-read-and-check-char
  (lambda (name expect-ch)
    (let ((ch (read-char)))
      (if (not (eqv? ch expect-ch))
          (error (sprintf "~A: expected ~S but got ~S" name expect-ch ch))))))

(define h-ignore-spaces
  (lambda ()
    (let loop ()
      (let ((c (peek-char)))
        (unless (or (eof-object? c) (not (char-whitespace? c)))
          (read-char)
          (loop))))))

;

(define h-read-until
  (lambda (pred?)
    (let loop ((r '()))
      (if (pred? (peek-char))
          (list->string (reverse! r))
          (loop (cons (read-char) r))))))

(define h-read-group
  (lambda ()
    ;simple group only, no nested braces
    (h-ignore-spaces)
    (h-read-and-check-char "h-read-group" #\{)
    (let ((s (h-read-until (lambda (c) (eqv? c #\})))))
      (h-read-and-check-char "h-read-group" #\})
      s)))

(define h-read-filename
  (lambda ()
    (h-ignore-spaces)
    (if (eqv? (peek-char) #\{) (h-read-group)
        (h-read-until (lambda (c)
                        (or (eof-object? c) (char-whitespace? c)))))))

;evaluating Scheme expressions in the input

(mistie-def-ctl-seq 'eval
  (lambda ()
    (eval (read))
    (h-ignore-spaces)))

;encode < > & "

(mistie-def-char #\< 
  (lambda ()
    (display "&lt;")))

(mistie-def-char #\> 
  (lambda ()
    (display "&gt;")))

(mistie-def-char #\& 
  (lambda ()
    (display "&amp;")))

(mistie-def-char #\" 
  (lambda ()
    (display "&quot;")))

;blank lines become paragraph separators

(define h-read-whitespace
  (lambda ()
    (let loop ((r '()))
      (let ((c (peek-char)))
        (if (or (eof-object? c) (not (char-whitespace? c)))
            (list->string (reverse! r))
            (loop (cons (read-char) r)))))))

(define h-number-of-newlines
  (lambda (ws)
    (let ((n (string-length ws)))
      (let loop ((i 0) (k 0))
        (if (>= i n) k
            (loop (+ i 1)
              (if (char=? (string-ref ws i) #\newline)
                  (+ k 1) k)))))))

(mistie-def-char #\newline
  (lambda ()
    (newline)
    (let* ((ws (h-read-whitespace))
           (n (h-number-of-newlines ws)))
      (if (> n 0)
          (begin (display "<p>")
            (newline) (newline))
          (display ws)))))

; verbatim

(mistie-def-ctl-seq 'p
  (lambda ()
    (h-ignore-spaces)
    (let* ((old-escape-char mistie-escape-char)
           (c (read-char))
           (ws (h-read-whitespace))
           (nnl (h-number-of-newlines ws))
           (pre? (> nnl 0)))
      (set! mistie-escape-char #f)
      (mistie-push-frame)
      (display (if pre? "<pre>" "<code>"))
      (display ws)
      (if (char=? c #\{)
          (let ((n 0))
            (set! mistie-escape-char #\|)
            (mistie-def-char #\{
              (lambda ()
                (display #\{)
                (set! n (+ n 1))))
            (mistie-def-char #\}
              (lambda ()
                (if (= n 0)
                    (begin
                      (display (if pre? "</pre>" "</code>"))
                      (mistie-pop-frame)
                      (set! mistie-escape-char old-escape-char))
                    (begin
                      (display #\})
                      (set! n (- n 1)))))))
          (mistie-def-char c
            (lambda ()
              (display (if pre? "</pre>" "</code>"))
              (display "</font>")
              (mistie-pop-frame)
              (set! mistie-escape-char old-escape-char))))
      (mistie-def-char #\newline newline))))

(mistie-def-ctl-seq 'q
  (mistie-lookup-ctl-seq 'p))

;emphasis, bold, smallprint

(define h-wrap-font
  (lambda (fontpre fontpost)
    (h-ignore-spaces)
    (h-read-and-check-char "h-wrap-font" #\{)
    (mistie-push-frame)
    (display fontpre)
    (mistie-def-char #\}
      (lambda ()
        (display fontpost)
        (mistie-pop-frame)))))

(mistie-def-ctl-seq 'i
  (lambda ()
    (h-wrap-font "<em>" "</em>")))

(mistie-def-ctl-seq 'b
  (lambda ()
    (h-wrap-font "<strong>" "</strong>")))

(mistie-def-ctl-seq 'small
  (lambda ()
    (h-wrap-font "<small>" "</small>")))

;stylesheet

(define h-stylesheet #f)

(mistie-def-ctl-seq 'stylesheet
  (lambda ()
	(print "ok")
    (write `(set! h-stylesheet ,(h-read-group)) h-aux-port)
    (newline h-aux-port)))

;title

(define h-title #f)

(mistie-def-ctl-seq 'title
  (lambda ()
    (let ((ti (h-read-group)))
      (write `(set! h-title ,ti) h-aux-port)
      (newline h-aux-port)
      (mistie-push-frame)
      (display "<h1><span class=subject>")
      (h-display-string ti)
      (display "</span></h1>")
      (newline) (newline)
      (h-ignore-spaces))))

;

(define h-write-char
  (lambda (c)
    (display
      (case c
        ((#\<) "&lt;")
        ((#\>) "&gt;")
        ((#\&) "&amp;")
        ((#\") "&quot;")
        (else c)))))

(define h-display-string
  (lambda (s)
    (let ((n (string-length s)))
      (let loop ((i 0))
        (unless (>= i n)
          (h-write-char (string-ref s i))
          (loop (+ i 1))))))) 

;sections

(define h-max-sec-depth 6)

(define h-sec-num-tbl 
  (list
    (cons 1 0) (cons 2 0) (cons 3 0)
    (cons 4 0) (cons 5 0) (cons 6 0)))

(define h-new-sec-num
  (lambda (lvl)
    (let ((c (assv lvl h-sec-num-tbl)))
      (set-cdr! c (+ (cdr c) 1)))
    (let loop ((i (+ lvl 1)))
      (unless (> i h-max-sec-depth)
        (set-cdr! (assv i h-sec-num-tbl) 0)
        (loop (+ i 1))))
    (let loop ((i 1) (r ""))
      (if (> i lvl) r
          (loop (+ i 1)
            (string-append r
              (number->string
                (cdr (assv i h-sec-num-tbl)))
              (if (= i lvl) "" ".")))))))

(define h-recent-label #f)
(define h-recent-label-value #f)

(define h-make-section
  (lambda (lvl)
    ((if (eqv? (peek-char) #\*)
         h-make-unnumbered-section
         h-make-numbered-section) lvl)))

(define h-make-unnumbered-section
  (lambda (lvl)
    (read-char)
    (h-ignore-spaces)
    (h-read-and-check-char "h-make-unnumbered-section" #\{)
    (mistie-push-frame)
    (display "<h") (display lvl) (display ">")
    (mistie-def-char #\}
      (lambda ()
        (display "</h") (display lvl) (display ">")
        (newline) (newline)
        (mistie-pop-frame)
        (h-ignore-spaces)))))

(define h-make-numbered-section
  (lambda (lvl)
    (h-ignore-spaces)
    (h-read-and-check-char "h-make-numbered-section" #\{)
    (let ((secnum (h-new-sec-num lvl)))
      (set! h-recent-label (string-append "SECTION_" secnum))
      (set! h-recent-label-value secnum)
      (mistie-push-frame)
      (display "<a name=\"")
      (display h-recent-label)
      (display "\">")
      (display "<h") (display lvl) (display ">")
      (display secnum)
      (display "&nbsp;&nbsp;")
      (mistie-def-char #\}
        (lambda ()
          (display "</h") (display lvl) (display ">")
          (newline) (newline)
          (mistie-pop-frame)
          (h-ignore-spaces))))))

(mistie-def-ctl-seq 'section
  (lambda ()
    (h-make-section 1)))

(mistie-def-ctl-seq 'subsection
  (lambda ()
    (h-make-section 2)))

(mistie-def-ctl-seq 'subsubsection
  (lambda ()
    (h-make-section 3)))

;url's

(mistie-def-ctl-seq 'urlh
  (lambda ()
    (let ((old-escape-char mistie-escape-char))
      (set! mistie-escape-char #f)
      (h-ignore-spaces)
      (h-read-and-check-char "urlh" #\{)
      (display "<a href=\"")
      (mistie-push-frame)
      (mistie-def-char #\newline newline)
      (mistie-def-char #\} 
        (lambda () (mistie-pop-frame)
          (set! mistie-escape-char old-escape-char)
          (display "\">")
          (h-ignore-spaces)
          (h-read-and-check-char "urlh" #\{)
          (mistie-push-frame)
          (mistie-def-char #\} 
            (lambda () (mistie-pop-frame)
              (display "</a>"))))))))

;

(mistie-def-ctl-seq 'obeylines
  (lambda ()
    (h-ignore-spaces)
    (h-read-and-check-char "obeylines" #\{)
    (h-ignore-spaces)
    (mistie-push-frame)
    (mistie-def-char #\newline
      (lambda ()
        (display "<br>") (newline)))
    (mistie-def-char #\}
      (lambda ()
        (mistie-pop-frame)))))

(mistie-def-ctl-seq 'flushright
  (lambda ()
    (display "<div align=right>")
    ((mistie-lookup-ctl-seq 'obeylines))
    (mistie-def-char #\}
      (lambda ()
        (mistie-pop-frame)
        (display "</div>")))))

;

(mistie-def-ctl-seq 'input
  (lambda ()
    (let ((f (h-read-filename)))
      (mistie-call-maybe  h-set-timestamp f)
      (let ((old-input (current-input-port)))
        (mistie-push-frame)
        (current-input-port
	 (open-input-file
	  (or (file-exists? f) (file-exists? (make-pathname (mistie-path) f))
	      (error "can not find file" f) ) ) )
        (mistie-def-char-type eof-object?
          (lambda (c)
            (current-input-port old-input)
            (mistie-pop-frame)))))))

;

(define h-string-rindex
  (lambda (s c)
    ;returns the rightmost index of s where c occurs
    (let loop ((i (- (string-length s) 1)))
      (cond ((< i 0) #f)
            ((char=? (string-ref s i) c) i)
            (else (loop (- i 1)))))))

(define h-file-stem
  (lambda (f)
    ;chop off f's dirname and extension
    (let ((slash (h-string-rindex f #\/)))
      (if slash
          (set! f (substring f (+ slash 1) (string-length f))))
      (let ((dot (h-string-rindex f #\.)))
        (if dot
            (substring f 0 dot)
            f)))))

(define h-aux-port #f)

;

(define h-start-page
  (lambda ()
    (display "<html><head>")
    (when h-stylesheet
      (display "<link rel=\"stylesheet\" type=\"text/css\" href=")
      (write h-stylesheet)
      (display " title=default>")
      (newline))
    (when h-title
      (display "<title>") (display h-title) (display "</title>")
      (newline))
    (display "</head><body")
    (unless h-stylesheet (display " bgcolor=white"))
    (display ">")
    (newline)))

(define h-end-page
  (lambda ()
    (mistie-call-maybe h-output-footnotes)
    (mistie-call-maybe h-nav-bar)
    (mistie-call-maybe h-print-timestamp)
    (display "<!-- page created by Mistie, ")
    (display "http://www.cs.rice.edu/~dorai/mistie/ -->")
    (newline)
    (display "</body></html>")
    (newline)))

(set! mistie-everyjob
  (lambda ()
    (let ((aux-file
            (string-append ".Z-A-" (h-file-stem mistie-jobname) ".scm")))
      (if (file-exists? aux-file) (load aux-file))
      (set! h-aux-port (open-output-file aux-file))
      (mistie-call-maybe h-set-timestamp mistie-jobname)
      (h-start-page))))

(mistie-def-char-type eof-object?
  (lambda (c)
    (h-end-page)
    (mistie-exit)))