(in-package :scribe-converter)

;; It always astonishes me that the simple yet powerful approaches get
;; totally lost in utter oblivion. I needed a couple of days to hack a
;; sane LaTeX parser, while this little Scribe parser was done in a
;; matter of minutes. And yet the keyword notion of Scribe is a little
;; nicer than what LaTeX has to offer. Let me also mention that an XML
;; parser also needs a couple of days to get right and yet XML is an
;; inferior data model.

;; ### what about "@foo{{a}}"?          bang! fix it! fix it!
;; ### what about "@foo{)}"?
;;     user.mss e.g. has @f[(]
;; ### we want #\newline #\newline -> (:par)

;; Just to settle on something, I now require that the delimiters used
;; by the command at hand are balanced and do not count any other. The
;; other delimiters are only "processed" when they actually are used
;; by a command or argument or somesuch.

;;     cmd -> '@' name LB^d any!d { ',' arg }* RB!d
;;   arg!d -> name { wsp+ | wsp* {'='|'/'} wsp* } value!(d u {','})
;; value!d -> LB^e { stuff!e }* RB!e
;;         -> {stuff!d}*
;; stuff!d -> cmd | { ANY - d }*
;;

(defun parse-error (string pos fmt &rest args)
  (let ((line-start (or (position #\newline string :end pos :from-end t)
                        0))
        (line-end (or (position #\newline string :start pos)
                      (length string))))
    (error "~?~&~A~%~vT^~%" fmt args
           (subseq string line-start line-end)
            (- pos line-start))))

(defun parse-stuff (delim string start end)
  (multiple-value-bind (x p2)
      (parse-command string start end)
    (if p2
        (values x p2)
        (if (and (< start end) (char= (char string start) #\@))
            (error "foo!")
            (parse-consume-upto (cons #\@ delim) string start end)))))

(defun parse-consume-upto (bag string start end)
  "Consume all character until a character is found which is a member in bag."
  (declare (type simple-string string)
           (type fixnum start end)
           ;;(type list bag)
           (optimize (speed 3) (safety 0)))
  (do* ((p start (the fixnum (+ p 1))))
       ((= p end)
        (values (subseq string start p)  p))
    (let ((c (char string p)))
      (when (find c bag)
        (return (values (subseq string start p) p)))
      (when (and (char= c #\newline)
                 (< (+ p 1) end)
                 (char= (char string (+ p 1)) #\newline))
        (return
          (values (subseq string start p) p))))))

(defun parse-stuff* (delim string start end &optional end-predicate)
  (multiple-value-bind (x p2) (parse-stuff delim string start end)
    (cond ((and end-predicate (funcall end-predicate x string p2))
           (values nil p2))
          ((= p2 end) (values (list x) p2))
          ((find (char string p2) delim)
           (values (list x) p2))
          ((and (char= (char string p2) #\newline)
                (< (+ p2 1) end)
                (char= (char string (+ p2 1)) #\newline))
           (multiple-value-bind (y p3)
               (parse-stuff* delim string (+ p2 2) end end-predicate)
             (values (list* x '(:par) y)
                     p3)))
          (t
           (multiple-value-bind (y p3)
               (parse-stuff* delim string p2 end end-predicate)
             (values (cons x y)
                     p3))))))

(defun parse-value (delim string start end)
  (multiple-value-bind (delim-2 p2) (parse-left-delimiter string start end)
    (cond (p2
           (multiple-value-bind (x p3) (parse-stuff* (list delim-2) string p2 end)
             (and p3
                  (multiple-value-bind (ignore p4) (parse-right-delimiter delim-2 string p3 end)
                    (declare (ignore ignore))
                    (and p4
                         (values x p4))))))
          (t
           (parse-stuff* delim string start end)))))

(defun parse-left-delimiter (string start end)
  (cond ((and (< start end)
              (left-delimiter-p (char string start)))
         (when (eql (char string start) #\')
           (warn "Saw #\\' delimiter at ~S:~D!" *current-file* start))
         (values
          (right-delimiter (char string start))
          (+ start 1)))
        (t
         nil)))

(defun parse-right-delimiter (delim string start end)
  (parse-char delim string start end))

(defun parse-char (char string start end)
  (cond ((and (< start end)
              (char= char (char string start)))
         (values
          :ignore
          (+ start 1)))
        (t
         nil)))

(defun parse-kw-arg (delim string start end)
  (multiple-value-bind (name p2) (parse-name string start end)
    (unless p2
      (parse-error string start "Expected argument name."))
    (and p2
         (multiple-value-bind (ignore p3) (parse-argument-assign string p2 end)
           (declare (ignore ignore))
           (unless p3
             (parse-error string p2 "Expected #\\= or #\\/ or white-space (argument/value seperator)."))
           (and p3
                (multiple-value-bind (value p4) (parse-value (cons #\, delim) string p3 end)
                  (and p4
                       (values
                        (cons (intern-keyword-name name) value)
                        p4))))))))

(defun parse-command (string start end)
  (multiple-value-bind (ignore p2) (parse-char #\@ string start end)
    (and p2
         (multiple-value-bind (name p3) (parse-command-name string p2 end)
           (setf name (intern-command-name name))
           (and p3
                (multiple-value-bind (args p4) (parse-command-arguments (command-signature name)
                                                                        string p3 end)
                  (and p4
                       (cond ((eql name :begin)
                              (let ((env (intern (string-upcase (pop args)) :keyword)))
                                (multiple-value-bind (body p5)
                                    (parse-stuff* nil string p4 end
                                                  (lambda (x string p)
                                                    ;;(print `(x ,x))(finish-output)
                                                    (cond ((and (consp x) (eql (car x) :end))
                                                           (unless (string-equal (cadr x) env)
                                                             (parse-error string p
                                                                          "Attempt to close ~S with ~S."
                                                                          env x))
                                                           t))))
                                  (values (cons env (append args body))
                                          p5))))
                             (t
                              (values (cons name args)
                                      p4))))))))))

(defun parse-command-arguments (signature string start end)
  (let ((p2 (skip-optional-white-space string start end)))
    (multiple-value-bind (delim p3) (and (not (null signature)) (parse-left-delimiter string p2 end))
      (cond ((null p3)
             #+NIL
             (unless (null signature)
               (parse-error string p2 "Where are my arguments?"))
             (values nil start))
            (t
             (multiple-value-bind (args p4) (parse-command-arguments-1
                                             (char string (- p3 1)) delim
                                             signature string p3 end)
               (unless p4
                 (parse-error string p3 "Somehow I miss arguments here."))
               (multiple-value-bind (ignore p7) (parse-right-delimiter delim string p4 end)
                 (declare (ignore ignore))
                 (unless p7
                   (parse-error string p3 "Right delimiter ~S missing here." delim))
                 (and p7
                      (values args p7)))))))))

(defun parse-command-arguments-1 (left-delim delim signature string start end)
  ;; ### more signature validation
  (let ((p3 (skip-optional-white-space string start end)))
    (cond ((null signature)
           (values nil p3))
          ((eql signature :whole)
           (parse-stuff* (list delim) string p3 end))
          ((eql signature :unparsed)
           (let ((level 1))
             (do ((p start (+ p 1)))
                 (nil)
               (cond ((= p end) (parse-error string start "EOF reached while trying to match left delimiter."))
                     ((char= (char string p) delim)
                      (decf level)
                      (when (zerop level)
                        (return (values (subseq string start p)
                                        p))))
                     ((char= (char string p) left-delim)
                      (incf level))))))
          ((eql (first signature) :name)
           (multiple-value-bind (arg p4) (parse-name string p3 end)
             (unless p4
               (parse-error string p3 "Expected name."))
             (setf p4 (skip-optional-white-space string p4 end)) ;won't hurt
             (multiple-value-bind (ignore p5) (parse-char #\, string p4 end)
               (declare (ignore ignore))
               (cond ((null p5)
                      ;;nothing more
                      (values
                       (list arg)
                       p4))
                     (t
                      ;; parse remaining
                      (multiple-value-bind (xs p6)
                          (parse-command-arguments-1 left-delim delim (cdr signature) string p5 end)
                        (and p6
                             (values (cons arg xs) p6))))))))
          ;;
          ((eql (first signature) :keywords)
           (multiple-value-bind (arg p4) (parse-kw-arg (list delim) string p3 end)
             (unless p4
               (parse-error string p3 "Expected keyword/value pair."))
             (setf p4 (skip-optional-white-space string p4 end)) ;won't hurt
             (multiple-value-bind (ignore p5) (parse-char #\, string p4 end)
               (declare (ignore ignore))
               (cond ((null p5)
                      ;;nothing more
                      (values
                       (list arg)
                       p4))
                     (t
                      ;; parse remaining
                      (multiple-value-bind (xs p6)
                          (parse-command-arguments-1 left-delim delim signature string p5 end)
                        (and p6
                             (values (cons arg xs) p6)))))))) )))

(defun intern-command-name (string)
  (intern (string-upcase string) :keyword))

(defun intern-keyword-name (string)
  (intern (concatenate 'string "." (string-upcase string)) :keyword))

(defun name-start-char-p (char)
  (alpha-char-p char))

(defun name-char-p (char)
  (alphanumericp char))

(defun parse-name (string start end)
  "Parse a single (argument or command) name and returns it verbatim."
  (and (< start end)
       (name-start-char-p (char string start))
       (do ((i (+ start 1) (+ i 1)))
           ((or (= i end)
                (not (name-char-p (char string i))))
            (values
             (subseq string start i)
             i)))))

(defun parse-argument-assign (string start end)
  (let ((p2 (skip-optional-white-space string start end)))
    (cond ((and (< p2 end)
                (find (char string p2) "=/"))
           (values
            nil
            (skip-optional-white-space string (+ p2 1) end)))
          ((>= p2 start)                ;###
           ;; some white space was present that is good enough for us.
           (values nil p2)))))

(defun parse-command-name (string start end)
  (and (< start end)
       (cond ((alpha-char-p (char string start))
              (do ((i (+ start 1) (+ i 1)))
                  ((or (= i end)
                       (not (alphanumericp (char string i))))
                   (values
                    (intern (string-upcase (subseq string start i)) :keyword)
                    i))))
             (t
              (values
               (intern (subseq string start (+ start 1)) :keyword)
               (+ start 1))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *command-names* nil)
(defparameter *env-names* nil)

(defvar +white-space+ '(#\space #\tab #\newline #\return #\page))
(defparameter +special-chars+ (format nil ")]}>'\"@~%"))

;; This is perhaps not like Scribe works internally, but I choose to
;; declare the signature of commands beforehand to be able to pull to
;; a highler level right in the parser. Some commands in Scribe seem
;; to take kind of keyword arguments specified in some fuzzy syntax.

(defun skip-optional-white-space (string start end)
  (do ((start start (+ start 1)))
      ((or (= start end)
           (not (white-space-p (char string start))))
       start)))

(defun white-space-p (char)
  (member char +white-space+))


(defun right-delimiter (c)
  (case c
    (#\( #\))
    (#\[ #\])
    (#\{ #\})
    (#\< #\>)
    (#\' #\')
    (#\" #\")
    (#\` #\')
    (otherwise nil)))

(defun left-delimiter-p (c)
  (find c "([{<'\"`"))

(defun right-delimiter-p (c)
  (find c ")]}>'\""))

(defun p (s)
  (parse-stuff* nil s 0 (length s)))

(defun parse-file (filename)
  (with-open-file (input filename :direction :input)
    (let* ((n (file-length input))
           (buf (make-array n :element-type (array-element-type ""))))
      (read-sequence buf input)
      (p buf))))

(defun parse-file (filename)
  (with-open-file (input filename :direction :input)
    (let* ((n (file-length input))
           (buf (make-array n :element-type (array-element-type ""))))
      (dotimes (i n)
        (setf (aref buf i) (read-char input)))
      (p buf))))

;; (:DEFCOM (:COM "Exit Hemlock") (:BIND "C-c, C-x C-z"))

;; Further:

;; @begin[foo] ... @end[foo] is considered to be equivalent to @foo[...]
;; Only problem: what is
;; @begin[foo, x=10] blah @end[foo] supposed to turn into?
;; on the SEXP level this is clear:
;; (:foo (:x "10") "blah")
;;

;;; Internal Representation

;; We choose to use new style LML. That is each node is represented
;; simply by:

;; node ::= ( <gi> <node>* )
;;        | <a-string>
;;   gi ::= <a-symbol>

;; Commands with keyword arguments turn the keywords into appropriate
;; sub-nodes, like:

;; @defcom[com "Sample Command", bind (C-M-q, C-`)] =>
;; (:defcom (:com "Sample Command") (:bind "C-M-q, C-`"))
;;


;; @begin[quotation, facecode i, leftmargin 8ems, rightmargin 3.5ems,
;; below 0.8 lines]
;; This command's name is @hid[Sample Command], and it is bound to
;; @w(@bf(C-M-q)) and @bf[C-`], meaning that typing either of these will
;; invoke it.  After this header comes a description of what the command does:
;; @end[quotation]
;; 
;; =>
;; 
;; (:quotation
;;  (:facecode "i") (:leftmargin "8ems") (:rightmargin "3.5ems") (:below "0.8 lines")
;;  "This command's name is " (:hid "Sample Command") ", and it is bound to
;; " (:w (:bf "C-M-q")) " and " (:bf "C-`") ", meaning that typing either of these will
;; invoke it.  After this header comes a description of what the command does:")
;;  
;;

#||
(define-environment defhvar enddefhvar (&key var val &body body)
  `(:DEFUN (:SIGNATURE
            :NAME ,var
            :PARAMS ,val
            :KIND "Variable")
    ,@body))

(define-command I (stuff) `(:I ,@stuff))
(define-command B (stuff) `(:B ,@stuff))

(define-command quotation (&key facecode leftmargin rightmargin below)
  )
||#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;
;; we now need to group @begin/@end and @defxyz/@enddefxyz as well as @section et al.
;;

(defclass command-def ()
  ((name      :initarg :name      :accessor command-def-name)
   (signature :initarg :signature :accessor command-def-signature)
   (expander  :initarg :expander  :accessor command-def-expander)))

(defvar *command-hash* (make-hash-table :test #'eq))

(defun define-command-1 (command-def)
  (setf (gethash (command-def-name command-def) *command-hash*) command-def))

(defun command-signature (command)
  (case command
    ((:begin) '(:name :keywords))
    ((:end)   '(:name))
    ((:hemlock :emacs) nil)
    ((:comment) :unparsed)
    (otherwise
     (let ((x (gethash command *command-hash*)))
       (if x (command-def-signature x) :whole)))))

(eval-when (compile load eval)
  (defun parse-command-definition-arguments (arguments)
    (let (keywords
          body
          (x arguments)
          upto-var upto-delim)
      (when (eq (car x) '&key)
        (pop x)
        (do () ((or (null x) (char= (char (symbol-name (car x)) 0) #\&)))
          (push (pop x) keywords)))
      (when (eq (car x) '&body)
        (pop x)
        (setf body (pop x)))
      (when (eq (car x) '&upto)
        (pop x)
        (setf upto-var (pop x))
        (setf upto-delim (pop x)))
      (unless (null x)
        (error "Command argument list malformed: ~S." arguments))
      (values keywords body upto-var upto-delim) )) )

(defmacro define-command (name arguments &body body)
  (setf name (intern (symbol-name name) :keyword))
  (multiple-value-bind (keywords body-arg upto-var upto-delim) (parse-command-definition-arguments arguments)
    `(define-command-1
      (make-instance 'command-def
       :name ',name
       :signature ',(cond (keywords '(:keywords))
                          (body ':whole)
                          (t nil))
       :expander (lambda (.this .rest)
                   (values
                    (let (,@(mapcar (lambda (kw)
                                      (list kw
                                            `(fetch-kw-argument .this ',(intern-keyword-name kw))))
                                    keywords)
                            ,@(if body-arg
                                  (list (list body-arg `(fetch-body .this))))
                            ,@(if upto-var
                                  (list (list upto-var
                                              `(multiple-value-bind (.x .r) (fetch-upto .rest ',upto-delim)
                                                (setf .rest .r)
                                                .x)))) )
                      ,@body)
                    .rest)) ))))

(defun fetch-kw-argument (node name)
  (cdr (find-if (lambda (x) (and (consp x) (eq (car x) name))) (cdr node))))

(defun fetch-body (node)
  ;; crude!
  (remove-if (lambda (x) (and (consp x) (char= (char (symbol-name (car x)) 0) #\.)))
             (cdr node)))

(defun fetch-upto (nodes delims)
  (when (atom delims) (setf delims (list delims)))
  (cond ((null nodes)
         nil
         #+NIL(error "Ran out of nodes while looking for &upto delimiter ~S." delims))
        ((and (consp (car nodes)) (member (caar nodes) delims))
         (values nil nodes))
        (t
         (multiple-value-bind (xs r) (fetch-upto (cdr nodes) delims)
           (values (cons (car nodes) xs)
                   r)))))

(defun process (node-list)
  (cond ((null node-list) nil)
        ((multiple-value-bind (x rest) (process-node (first node-list) (rest node-list))
           (cond ((and (consp x) (eq (car x) :splice))
                  (append (cdr x) (process rest)))
                 (t
                  (cons x (process rest))))))))

(defvar *unknown-commands* nil)

(defun process-node (node rest &aux x)
  (cond ((stringp node)
         (values node rest))
        ((eq (car node) :comment)
         (values `(:splice) rest))
        ((eq (car node) :par)
         (values `(:par) rest))
        ((setf x (gethash (car node) *command-hash*))
         (funcall (command-def-expander x) node rest))
        (t
         (unless (member (car node) *unknown-commands*)
           (warn "Command ~S not defined." (car node))
           (push (car node) *unknown-commands*))
         (values `(:splice ,@(process (fetch-body node)))
                 rest))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro define-ignore (name) `(define-command ,name (&body body) '(:splice)))
(defmacro define-nop (name)    `(define-command ,name (&body body) `(:splice ,@(process body))))

(define-command i (&body body) `(:I ,@(process body)))
(define-command bf (&body body) `(:B ,@(process body)))
(define-command b (&body body) `(:B ,@(process body)))

;; @commandstring[windows = "X windows"]

(define-command windows () "X windows")

;;@commandstring[llisp = "L@c(isp)"]
;;cmulisp.sty:\def\llisp{{Common Lisp}}
;;(define-command llisp () "Common Lisp")

(define-command hemlock () "Hemlock")
(define-command mh () "MH")
(define-command emacs () "Emacs")
(define-command llisp () "Lisp")
(define-command clisp () "Common Lisp")
(define-command nil () '(:CL "nil"))
(define-command true () '(:CL "t"))

(define-command dash () " -- ")

(define-command optional () '(:GROUP (:FONT :FACE :RM) "&optional"))
(define-command rest     () '(:GROUP (:FONT :FACE :RM) "&rest"))
(define-command key      () '(:GROUP (:FONT :FACE :RM) "&key"))
(define-command aux      () '(:GROUP (:FONT :FACE :RM) "&aux"))
(define-command body     () '(:GROUP (:FONT :FACE :RM) "&body"))
(define-command nil      () `(:CL "nil"))
(define-command false    () `(:CL "nil"))

(define-command t (&body body) `(:GROUP (:FONT :FACE :tt) ,@(process body))) ;typewriter?
(define-command f (&body body) `(:GROUP (:FONT :FACE :tt) ,@(process body))) ;function?
(define-command f2 (&body body) `(:GROUP (:FONT :FACE :tt) ,@(process body))) ;used for bindings et al
(define-command varref (&body body) `(:CL ,@(process body)))
(define-command funref (&body body) `(:CL ,@(process body)))
(define-command macref (&body body) `(:CL ,@(process body)))
(define-command hvarref (&body body) `(:CL ,@(process body)))
(define-command kwd (&body body) `(:CL ":" ,@(process body)))
(define-command comref (&body body) `(:CL ,@(process body)))
(define-command hid (&body body) `(:CL ,@(process body)))

(define-command var (&body body) `(:I ,@(process body)))

(define-command index (&body body) '(:SPLICE)) ;###
(define-command foot (&body body) '(:SPLICE)) ;###
(define-command label (&body body) `(:LABEL :name ,(first body)))
(define-command tag (&body body) `(:SPLICE ,@(process (list `(:LABEL ,@body))))) ;synonym for @label?
(define-command ref (&body body) `(:REF :name ,(first body)))
(define-command pageref (&body body) `(:REF :name ,(first body))) ;###

(define-command programexample (&body body)
  `(:splice ,@(process body)))

(define-command @ () "@")

(define-ignore commandstring)
(define-ignore device)
(define-ignore make)
(define-ignore style)
(define-ignore use)
(define-ignore libraryfile)
(define-ignore string)
(define-ignore blankspace)
(define-ignore \;)                      ;the meaning of this totally escapes me
(define-ignore newpage)

(define-nop multiple)
(define-nop w)                          ;### this probably is s.th. like nowrap

(define-nop text)
;; just used like this:
#|
@begin(Text, indent 0)
This document describes how to write commands for the @Hemlock text editor, as
of version M3.2.  @Hemlock is a customizable, extensible text editor whose
initial command set closely resembles that of ITS/TOPS-20 @Emacs.  @Hemlock is
written in the CMU Common Lisp and has been ported to other implementations.
@end(Text)
|#

;; @textform<binding = "@f2[@w(@parm{text})]">

(define-command binding (&body body) `(:splice ,@(process (list `(:f2 (:w ,@body))))))

#||
;; hmm
(define-command programexample (&body body)
  `(:PRE
    ,(reduce (lambda (x y)
               (cond ((equal x '(:par)) (setf x (format nil "~%~%"))))
               (cond ((equal y '(:par)) (setf y (format nil "~%~%"))))
               (concatenate 'string x y)) (process body))))
||#

(define-command itemize (&body body)
  (let ((items (glisp:split-by-if (lambda (x) (equal x '(:par))) body :nuke-empty-p t)))
    `(:UL
      ,@(mapcar (lambda (item)
                  `(:LI ,@(process item)))
                items))))

(define-command enumerate (&body body)
  (let ((items (glisp:split-by-if (lambda (x) (equal x '(:par))) body :nuke-empty-p t)))
    `(:OL
      ,@(mapcar (lambda (item)
                  `(:LI ,@(process item)))
                items))))

(define-command description (&body body)
  ;; i have no idea if this is right ...
  (let ((items (glisp:split-by-if (lambda (x) (equal x '(:par))) body :nuke-empty-p t)))
    `(:DL
      ,@(mapcan (lambda (item)
                  (let ((q (glisp:split-by-if (lambda (x) (equal x '(:\\))) item)))
                    (unless (= 2 (length q))
                      (error "Adjust your idea of the Description environment."))
                    (list 
                     `(:DT ,@(process (first q)))
                     `(:DD ,@(process (second q))))))
                items))))

;;;

(defvar *in-defun-p* nil)

(defmacro defdefun (name args signature-maker)
  (let ((end (intern (concatenate 'string "END" (symbol-name name))
                     :keyword))
        (name1 (intern (concatenate 'string (symbol-name name) "1")
                       :keyword)))
    `(progn
      (define-command ,name (&key ,@args &upto body ,end)
        `(:DEFUN
          ,,signature-maker
          ,@(let ((*in-defun-p* t))
                 (process body))))
      (define-command ,name1 (&key ,@args)
        (cond (*in-defun-p*
               ,signature-maker)
              (t
               (warn "I am not in :DEFUN -- ~S." .this)
               '(:SPLICE))))
      (define-command ,end () '(:SPLICE)) )))

(defdefun defcon (var)
  `(:SIGNATURE :NAME ((:CL ,@(process var))) :PARAMS NIL :KIND ("Constant")))

(defdefun defvar (var)
  `(:SIGNATURE :NAME ((:CL ,@(process var))) :PARAMS NIL :KIND ("Variable")))

(defdefun defun (fun args)
  `(:SIGNATURE :NAME ((:CL ,@(process fun))) :PARAMS ,(process args) :KIND ("Function")))

(defdefun defmac (fun args)
  `(:SIGNATURE :NAME ((:CL ,@(process fun))) :PARAMS ,(process args) :KIND ("Macro")))

(defdefun defcom (com bind)
  `(:SIGNATURE
    :NAME ((:CL ,@(process com)))
    :PARAMS ,(if bind `("(bound to " (:B ,@(process bind)) ")") nil)
    :KIND ("Command")))

(defdefun defhvar (var val)
  `(:SIGNATURE
    :NAME ((:CL ,@(process var)))
    :PARAMS ("(initial value " (:CL ,@(process val)) ")")
    :KIND ("Variable")))

;;;

(define-command part (&body title &upto body (:part))
  `(:SECTION
    :TITLE ,(process title)
    :KIND :PART
    ,@(process body)))

(define-command chap (&body title &upto body (:chap :chapter :part))
  `(:SECTION
    :TITLE ,(process title)
    :KIND :CHAPTER
    ,@(process body)))

(define-command chapter (&body title &upto body (:chap :chapter :part))
  `(:SECTION
    :TITLE ,(process title)
    :KIND :CHAPTER
    ,@(process body)))

(define-command section (&body title &upto body (:section :chap :chapter :part))
  `(:SECTION
    :TITLE ,(process title)
    :KIND :SECTION
    ,@(process body)))

(define-command subsection (&body title &upto body (:subsection :section :chap :chapter :part))
  `(:SECTION
    :TITLE ,(process title)
    :KIND :SUBSECTION
    ,@(process body)))

(define-command paragraph (&body title &upto body (:paragraph :subsection :section :chap :chapter :part))
  `(:SECTION
    :TITLE ,(process title)
    :KIND :PARAGRAPH
    ,@(process body)))

(defvar *current-file* (pathname ""))

(defun fetch-file (filename)
  (let ((filename (merge-pathnames filename *current-file*)))
    (let ((*current-file* filename))
      (let ((x (parse-file filename)))
        (labels ((walk (x)
                   (cond ((atom x) (list x))
                         ((eq (car x) :comment) nil)
                         ((eq (car x) :include)
                          (fetch-file (cadr x)))
                         ((consp x)
                          (list
                           (cons (car x)
                                 (mapcan #'walk (cdr x))))))))
          (mapcan #'walk x))))))

(defun process-file (filename)
  (process (fetch-file filename)))

(define-command include (&body name)
  `(:SPLICE ,@(process-file (first name))))

#+NIL
(defun q (filename)
  (setf *unknown-commands* nil)
  (with-open-file (output "/tmp/dump0" :if-exists :new-version :direction :output)
    (print
     (list `(:document :kind :document
             :title ("Hemlock Manual")
             ,@(process-file filename)
             (:printindex)))
     output))
  (values))


;; --------------------------------------------------------------------------------

;; format is used like this:

#|
@tabclear
@tabdivide(3)

@begin[format, spacing 1.5]

@Begin[Center] @b[Global bindings:] @End[Center]

@hid[Incorporate and Read New Mail]@\\@\\@bf[C-x i]
@hid[Send Message]@\\@\\@bf[C-x m]
@hid[Message Headers]@\\@\\@bf[C-x r]
|#

#||
(define-command format (&body body)
  (setf body (glisp:split-by-if (lambda (x) (equal x '(:par)))
                                (subst '(:PAR) (format nil "~%") body)))
  `(:TABLE
    ...))
||#