(in-package :cl-user)
(import '(lhtml:gi lhtml:children lhtml:attr lhtml:attributes))
;; 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 my-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
(my-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
(my-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))))))))
(defparameter *single-char-commands*
nil
"Single character commands that take no arguments")
(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
(cond ((member name *single-char-commands*)
)
(t
(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)
(my-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)
(my-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
(my-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
(my-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) (my-parse-error string start "EOF reached while trying to match left delimiter."))
((char= (char string p) delim)
(decf level)
(when (zerop level)
(return (values (list (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
(my-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) :kname)
(multiple-value-bind (arg p4) (parse-name string p3 end)
(setf arg (intern-keyword-name arg))
(unless p4
(my-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
(my-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-start-char-p (char)
(name-char-p char))
(defun name-char-p (char)
(or (alphanumericp char) (char= 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)
(defparameter +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)))
(cons :document (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 ::=
;; 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-`"))
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 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)
((:_ :\\ :SYSTEMKEY :dot) nil)
((:case) '(:kname :keywords))
((:value) '(:kname))
((:ref) '(:kname))
((:tag) '(:keywords))
((:BREAKKEY
:SYSTEMKEY
:RUBOUTHANDLERTERM
:QFASL
:CCFILE)
nil)
((:FunctionDoc :errordoc :extcomdoc :keydoc :VARIABLEDOC :randomdoc :Pageheading :pagefooting :string :form) '(:keywords))
(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) )) )
(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))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;; -- Zeta-C --------------------------------------------------------------------------------
(defun collect-gis (tree)
(let ((res nil))
(labels ((walk (tree)
(cond ((atom tree) nil)
(t
(pushnew (car tree) res)
(mapc #'walk (cdr tree))))))
(walk tree)
res)))
; (:PI :* :QUOTATION :|:| :SEC :BIG :RESECTION :@ :EXTCOMDOC :|;| :KEYDOC :_
; :VARIABLEDOC :SMALL :RUBOUTHANDLERTERM :RANDOMDOC :GROUP :CAPTION :.FONT
; :HINGE :FIGURE :ITEMIZE :PARAGRAPH :ERRORDOC :FUNCTIONDOC :DOT :DISPLAYONE :W
; :INFINITY :SUBSECTION :B :SECTION :|\\| :.INDENT :.SPREAD :.FILL :DESCRIPTION
; :FOOT :NOHINGE :IT :CCFILE :SYSTEMKEY :QFASL :BREAKKEY :NOTCT :DISPLAY :TAG
; :CHAPTER :REF :LT :INDEX :I :PREFACESECTION :ESCAPE :PAGEHEADING :.MARGINS
; :TEXT :NEWPAGE :MONTHNAME :VALUE :CENTER :+ :MAJORHEADING :BLANKSPACE
; :PAGEFOOTING :ST :~ :FORM :STRING :ODDVALUE :CHAR :SET :CASE :TCT :DEFINE
; :STYLE :PAR :MAKE :COMMENT)
;; :pi => \pi{} or s.th.
(defun nuke-strings (tree)
(setf tree (remove-if #'stringp tree))
(cons (car tree) (mapcar #'nuke-strings (cdr tree))))
(defun gi-type (gi)
(ecase gi
;; inline
((:PI ;the pi symbol
:*
:|:|
:SEC ; "section" used as @sec@:1.2
:BIG
:@ ; = "@"
:|;|
:_ ; nbsp?
:SMALL ; => makes text small
:RUBOUTHANDLERTERM ; => "rubout handler"
:DOT ; raised dot
:DISPLAYONE ; seems to do nothing
:W ; no clue, what one does.
:INFINITY ; infinity sign
:B
:\\ ; separator for description
:FOOT ;foot note
:NOHINGE ; no idea
:HINGE
:IT
:CCFILE ; => string
:SYSTEMKEY ; => string
:QFASL ; => string
:BREAKKEY ; => string
:NOTCT ; no idea
:REF
:LT
:CL
:I
:ESCAPE ; PS escape
:MONTHNAME
:VALUE ;retrieves a string value
:+ ;superscript
:ST ;tt?
:~) ;line continuation?
:inline)
((:QUOTATION
:RESECTION
:EXTCOMDOC
:KEYDOC
:VARIABLEDOC
:RANDOMDOC
:ERRORDOC
:FUNCTIONDOC
:GROUP
:CAPTION
:FIGURE
:ITEMIZE
:PARAGRAPH
:SUBSECTION
:SECTION
:DESCRIPTION
:DISPLAY
:CHAPTER
:PREFACESECTION
:PAGEHEADING
:SET ;sets some variablees
:NEWPAGE
:TEXT ;no idea
:CENTER
:MAJORHEADING ;sets document title
:BLANKSPACE ;vertical space
:PAGEFOOTING
:PAR)
:block)
((:TAG)
:hollow)
((:index
;; noise [for now]
:STRING ;sets a string
:FORM ;also sets a string
;; meta
:CASE
:PAR
:COMMENT
:DOCUMENT)
:noise) ))
;;;; -- String and Form expansion, @case, @comment --------------------------------------------
(defun preprocess-tree (tree)
(let ((map nil)
(mmap nil))
(labels ((walk (node)
(cond ((atom node) (list node))
((case (car node)
((:value)
(list
(or (getf map (cadr node))
(progn
(warn "~S not defined." (cadr node))
""))))
((:string)
(setf (getf map (car (cadr node)))
(cadr (cadr node)))
nil)
((:comment :set
) ;for now
nil)
((:form)
(loop for (k . v) in (cdr node) do
(warn "Defining ~S." (intern (remove #\. (symbol-name k)) :keyword))
(setf (getf mmap (intern (remove #\. (symbol-name k)) :keyword))
v))
nil)
((:case)
(let ((val (intern-keyword-name (getf map (cadr node)))))
(let ((res (copy-list (cdr (assoc val (cddr node))))))
;(warn "~S -> ~S" node res)
(mapcan #'walk res))))
(otherwise
(let ((x (getf mmap (car node))))
(if x
(copy-list x)
(list
(cons (car node) (mapcan #'walk (cdr node))))))))))))
(car (walk tree)))))
;;;; -- Conversion ----------------------------------------------------------------------------
;; we emit HTML
;; block: H1, H2, H3, H4, HR, DIV, PRE, BLOCKQUOTE, CENTER, DL, UL, P,
;; inline: I, B, TT, SUP, ENTITY, BIG, SMALL,
;; new: DEFUN, FIGURE, NEWPAGE
(defun white-string-p (x)
(and (stringp x)
(every #'white-space-p x)))
(defun enpar* (nodes &optional (gi :P))
(labels ((foo (node-list)
(cond ((null node-list)
nil)
(t
(let ((p (or (position-if (lambda (x)
(and (consp x)
(or (eql :block (gi-type (car x)))
(eql :hollow (gi-type (car x))))
))
node-list)
(length node-list))))
(cond ((and (= p 0) (eql :par (caar node-list)))
(foo (cdr node-list)))
((= p 0)
(cons (car node-list)
(foo (cdr node-list))))
(t
(cond ((every #'white-string-p (subseq node-list 0 p))
(foo (subseq node-list p)))
(t
(cons (cons gi (subseq node-list 0 p))
(foo (subseq node-list p))))))))))))
(foo nodes)))
(defun enpar (node &optional (gi :P))
(cons (car node) (enpar* (cdr node) gi)))
(defun convert-block (node)
(let ((kws nil) (children nil))
(loop for child in (cdr node) do
(cond ((and (consp child) (char= #\. (char (symbol-name (first child)) 0)))
(push (cdr child) kws)
(push (intern (remove #\. (symbol-name (first child))) :keyword) kws))
(t
(push child children))))
(apply #'convert-block-1 (car node) (reverse children) kws)))
(defgeneric convert-inline-1 (gi children &key))
(defgeneric convert-block-1 (gi children &key))
(defun convert-inline (node)
(cond ((consp node)
(let ((kws nil) (children nil))
(loop for child in (cdr node) do
(cond ((and (consp child) (char= #\. (char (symbol-name (first child)) 0)))
(push (cdr child) kws)
(push (intern (remove #\. (symbol-name (first child))) :keyword) kws))
(t
(push child children))))
(apply #'convert-inline-1 (car node) (reverse children) kws)))
(t
node)))
(defun convert-inline* (nodes)
(mapcar #'convert-inline nodes))
(defun convert-block* (nodes)
(mapcar #'convert-block (enpar* nodes)))
(defparameter +style+
"H1, H2, H3, H4 { font-family: sans-serif; text-transform: uppercase; letter-spacing: 3pt;
color: #666; margin-left: 24pt; }
H1 { font-size: 24pt; text-align: center; margin-left: 0; }
H2 { font-size: 18pt; }
BODY { padding: 1em 4em; font-size: 12pt; }
P { text-align: justify; }
PRE { background: #ffe; border: 1px solid #666; padding: 1ex 1em; }
")
(defmethod convert-block-1 ((gi (eql :document)) children &key)
`(:html
(:head
(:style ,+style+))
(:body
,@(mapcar #'convert-block (enpar* children)))))
(defmethod convert-block-1 ((gi (eql :chapter)) children &key)
`(:h1 ,@(convert-inline* children)))
(defmethod convert-block-1 ((gi (eql :section)) children &key)
`(:h2 ,@(convert-inline* children)))
(defmethod convert-block-1 ((gi (eql :resection)) children &key) ;XXX
`(:h3 ,@(convert-inline* children)))
(defmethod convert-block-1 ((gi (eql :subsection)) children &key)
`(:h3 ,@(convert-inline* children)))
(defmethod convert-block-1 ((gi (eql :paragraph)) children &key)
`(:h4 ,@(convert-inline* children)))
(defmethod convert-block-1 ((gi (eql :newpage)) children &key)
(cond (*for-latex-p*
`(:newpage))
(t
`(:hr)) )) ;### best we can do
(defmethod convert-block-1 ((gi (eql :group)) children &key)
`(:div ,@(convert-block* children))) ;### best we can do
(defmethod convert-block-1 ((gi (eql :p)) children &key)
`(:p ,@(convert-inline* children)))
(defun kill-leading-newline (nodes)
(cond ((null nodes) nil)
((stringp (car nodes))
(let ((x (string-left-trim (format nil "~%") (car nodes))))
(cond ((= 0 (length x))
(kill-leading-newline (cdr nodes)))
(t
(cons x (cdr nodes))))))
(t
nodes)))
(defun kill-trailing-newline (nodes)
(cond ((null nodes) nil)
((stringp (car (last nodes)))
(let ((x (string-right-trim (format nil "~%") (car (last nodes)))))
(cond ((= 0 (length x))
(kill-trailing-newline (butlast nodes)))
(t
(append (butlast nodes) (list x))))))
(t
nodes)))
(defun kill-surrounding-newline (nodes)
(kill-trailing-newline (kill-leading-newline nodes)))
;;;; -- Whitespace ----------------------------------------------------------------------------
(defun cons-node (gi attributes children)
(append (list gi) attributes children))
(defun sanify-white-space (node &optional beginp endp)
(cond ((stringp node)
(when beginp
(setf node (string-left-trim +white-space+ node)))
(when endp
(setf node (string-right-trim +white-space+ node)))
(if (> (length node) 0)
node
'(:splice)))
(t
(when (and beginp (children node))
(setf node
(cons-node (gi node) (attributes node)
(cons (sanify-white-space (first (children node)) t nil)
(rest (children node))))))
(when (and endp (children node))
(setf node
(cons-node (gi node) (attributes node)
(append (butlast (children node))
(list
(sanify-white-space (car (last (children node))) nil t))))))
node)))
(defmethod convert-block-1 ((gi (eql :display)) children &key)
;; TODO: kill leading newlines
`(:pre
,@(kill-surrounding-newline (convert-inline* (loop for x in children collect (if (equal x '(:par)) (format nil "~%~%") x))))))
(defmethod convert-block-1 ((gi (eql :quotation)) children &key)
`(:blockquote ,@(convert-block* children)))
(defmethod convert-block-1 ((gi (eql :center)) children &key)
`(:center ,@(convert-block* children)))
(defmethod convert-block-1 ((gi (eql :prefacesection)) children &key)
(cond (*for-latex-p*
`(:h2* ,@(convert-inline* children)))
(t
`(:h1 ,@(convert-inline* children)))))
;; docs
(defmethod convert-block-1 ((gi (eql :functiondoc)) children &key name arglist doc)
(assert (null children))
(gendefun name arglist (list "Function") doc))
(defmethod convert-block-1 ((gi (eql :variabledoc)) children &key name doc)
(assert (null children))
(gendefun name nil (list "Variable") doc))
(defmethod convert-block-1 ((gi (eql :errordoc)) children &key message doc)
(assert (null children))
(gendefun message nil (list "Error") doc))
(defmethod convert-block-1 ((gi (eql :extcomdoc)) children &key name doc)
(assert (null children))
(gendefun name nil (list "Extended Command") doc))
(defmethod convert-block-1 ((gi (eql :keydoc)) children &key key name doc)
(assert (null children))
(gendefun key name (list "Key") doc))
(defmethod convert-block-1 ((gi (eql :randomdoc)) children &key name kind doc)
(assert (null children))
(gendefun name nil kind doc))
;;; for now:
(defvar *for-latex-p* t)
(defun gendefun (name arglist kind doc)
(cond (*for-latex-p*
`(:defun :name ,(convert-inline* name)
:kind ,(convert-inline* kind)
:args ,(convert-inline* arglist)
,@(convert-block* doc)))
(t
`(:dl
(:dt (:b ,@(convert-inline* name))
" "
,@(convert-inline* arglist)
" [" ,@(convert-inline* kind) "]")
(:dd
,@(convert-block* doc))))))
(defmethod convert-block-1 ((gi (eql :itemize)) children &key)
;; ### not yet fine
(let ((xs (mapcar #'convert-block (enpar* children))))
`(:UL
,@(mapcar (lambda (x) (list :li x)) xs))))
(defmethod convert-block-1 ((gi (eql :itemize)) children &key)
;(warn "~S" children)
(let ((items (split-sequence:split-sequence-if (lambda (x) (equal x '(:par))) children :remove-empty-subseqs t)))
`(:UL
,@(mapcar (lambda (item)
`(:LI ,@(convert-block* item)))
items))))
(defmethod convert-block-1 ((gi (eql :description)) children &key &allow-other-keys)
(let ((items (split-sequence:split-sequence-if (lambda (x) (equal x '(:par))) children :remove-empty-subseqs t)))
`(:DL
,@(mapcan (lambda (item)
(let ((q (split-sequence:split-sequence-if (lambda (x) (equal x '(:\\))) item)))
(cond ((/= 2 (length q))
(warn "~S" q)
(warn "Adjust your idea of the Description environment.")
nil)
(t
(list
`(:DT ,@(convert-inline* (first q)))
`(:DD ,@(convert-block* (second q))))))))
items))))
(defmethod convert-block-1 ((gi (eql :figure)) children &key &allow-other-keys)
(cond (*for-latex-p*
`(:figure
,@(convert-block* children)))
(t
;; best we can do i guess
`(:DIV
:STYLE "border: 1px solid; margin: 1em; padding: 1em 1ex;"
,@(convert-block* children)))))
(defmethod convert-block-1 ((gi (eql :caption)) children &key &allow-other-keys)
(cond (*for-latex-p*
`(:caption ,@(convert-inline* children)))
(t
;; best we can do i guess
`(:P
,@(convert-inline* children)))))
(defmethod convert-block-1 (gi children &key &allow-other-keys)
(warn "Block ~S not defined." gi)
(list :splice))
(defmethod convert-inline-1 ((gi (eql :i)) children &key)
`(:i ,@(convert-inline* children)))
(defmethod convert-inline-1 ((gi (eql :b)) children &key)
`(:b ,@(convert-inline* children)))
(defmethod convert-inline-1 ((gi (eql :st)) children &key) `(:splice ,@(convert-inline* children)))
(defmethod convert-inline-1 ((gi (eql :lt)) children &key) `(:b ,@(convert-inline* children)))
(defmethod convert-inline-1 ((gi (eql :cl)) children &key) `(:tt ,@(convert-inline* children)))
(defmethod convert-inline-1 ((gi (eql :st)) children &key) `(:tt ,@(convert-inline* children)))
(defmethod convert-inline-1 ((gi (eql :lt)) children &key) `(:tt ,@(convert-inline* children)))
(defmethod convert-inline-1 ((gi (eql :it)) children &key)
`(:i ,@(convert-inline* children)))
(defmethod convert-inline-1 ((gi (eql :+)) children &key)
`(:sup ,@(convert-inline* children)))
(defmethod convert-inline-1 ((gi (eql :pi)) children &key) `(:entity :name "pi"))
(defmethod convert-inline-1 ((gi (eql :infinity)) children &key) `(:entity :name "infin"))
(defmethod convert-inline-1 ((gi (eql :dot)) children &key) `(:entity :name "sdot"))
(defmethod convert-inline-1 ((gi (eql :@)) children &key) "@")
(defmethod convert-inline-1 ((gi (eql :\;)) children &key) ;no idea
"")
(defmethod convert-inline-1 ((gi (eql :sec)) children &key) "section") ;?
(defmethod convert-inline-1 ((gi (eql :|:|)) children &key) '(:entity :name "nbsp")) ;a guess
(defmethod convert-inline-1 ((gi (eql :big)) children &key)
`(:splice ,@(convert-inline* children)))
(defmethod convert-inline-1 ((gi (eql :small)) children &key)
`(:small ,@(convert-inline* children)))
(defmethod convert-inline-1 ((gi (eql :notct)) children &key) ;nowrap?
`(:splice ,@(convert-inline* children)))
(defmethod convert-inline-1 ((gi (eql :w)) children &key)
;; no idea
`(:splice ,@(convert-inline* children)))
(defmethod convert-inline-1 ((gi (eql :displayone)) children &key)
;; perhaps #\space -> #\nbsp?
`(:tt ,@(convert-inline* children)))
(defmethod convert-inline-1 ((gi (eql :hinge)) children &key &allow-other-keys) ;text-indent?!
(list :splice))
(defmethod convert-inline-1 ((gi (eql :nohinge)) children &key &allow-other-keys) ;text-indent?!
(list :splice))
(defvar *ref-kind* (make-hash-table))
(defmethod convert-inline-1 ((gi (eql :ref)) children &key &allow-other-keys)
(cond (*for-latex-p*
(cond ((string-equal "page" (gethash (first children) *ref-kind*))
`(:page-ref ,(remove #\. (string-downcase (first children)))))
(t
`(:ref ,(remove #\. (string-downcase (first children)))))))
(t
;; ### hmm
`(:a :href "foo" ,@(convert-inline* children)))))
(defmethod convert-block-1 ((gi (eql :ref)) children &key &allow-other-keys)
(convert-inline-1 gi children))
(defmethod convert-inline-1 ((gi (eql :tag)) children &rest xs &key &allow-other-keys)
(cond (*for-latex-p*
(setf (gethash (intern-keyword-name (string (car xs))) *ref-kind*) (car (cadr xs)))
`(:tag ,(remove #\. (string-downcase (car xs)))))
(t
;; ### hmm
`(:a :href "foo" ,@(convert-inline* children)))))
(defmethod convert-block-1 ((gi (eql :tag)) children &rest xs &key &allow-other-keys)
(apply #'convert-inline-1 gi children xs))
(defmethod convert-inline-1 ((gi (eql :index)) children &key &allow-other-keys)
(cond (*for-latex-p*
`(:index ,@(convert-inline* children)))
(t
;; ### hmm
`(:splice))))
(defmethod convert-block-1 ((gi (eql :index)) children &key &allow-other-keys)
(convert-inline-1 gi children))
(defmethod convert-inline-1 ((gi (eql :foot)) children &key &allow-other-keys)
(cond (*for-latex-p*
`(:footnote ,@(convert-block* children)))
(t
(warn "inline ~S not defined." gi)
(list :splice))))
(defmethod convert-inline-1 (gi children &key &allow-other-keys)
(warn "inline ~S not defined." gi)
(list :splice))
(defun foo ()
(let ((x (convert-block (preprocess-tree (parse-file "boo.ms")))))
(with-open-file (output "/tmp/a.html" :direction :output :if-exists :supersede)
(write-line "" output)
(lhtml:write-lhtml x output))
(values)))
;; ### blah! @display is kind of inline in manual.ms
;;;; -- TODO ----------------------------------------------------------------------------------
;; in inline elements sanify the white space.
;; kill leading new lines
;; @index, @tag, @ref
;; toc.
;; (p "@Index(lispval (type))") => ((:INDEX "lispval (type") ")"), which is wrong
;; Hmm @lt<=>>?
;; -- => —
;;;; -- Latex ---------------------------------------------------------------------------------
(defvar *latex-pre-mode-p* nil)
(defvar *latex-encoding* :t1)
(defvar *latex-last-was-white* t)
(defvar *par-needed-p* nil)
(defun latex-ensure-par ()
(when *par-needed-p*
(fresh-line)
(terpri)
(setf *latex-last-was-white* t)
(setf *par-needed-p* nil)))
(defgeneric latex-block-1 (gi children &key))
(defgeneric latex-inline-1 (gi children &key))
(defun latex-block (node)
(apply #'latex-block-1 (gi node) (children node) (attributes node)))
(defun latex-inline (node)
(cond ((stringp node)
(latex-text node))
(t
(apply #'latex-inline-1 (gi node) (children node) (attributes node)))))
(defparameter +latex-preample+
"% -*- Mode: Latex; -*-
\\documentclass[11pt]{scrbook}
%\\usepackage{defun}
\\usepackage{makeidx}
\\makeindex
\\usepackage{base}
\\usepackage{a4wide}
\\usepackage{parskip}
\\usepackage{color}
\\usepackage{graphics}
\\renewcommand{\\rmdefault}{ptm}
\\renewcommand{\\sfdefault}{phv}
\\raggedbottom
\\title{ZETA-C$^{\\mbox{(TM)}}$ User's Guide} %(tm)?
")
(defmethod latex-block-1 ((gi (eql :html)) children &key)
(write-string +latex-preample+)
(mapc #'latex-block children))
(defmethod latex-block-1 ((gi (eql :head)) children &key)
)
(defmethod latex-block-1 ((gi (eql :body)) children &key)
(write-line "\\begin{document}")
(write-line "\\maketitle")
(write-line "\\tableofcontents")
(mapc #'latex-block children)
(write-line "\\printindex")
(write-line "\\end{document}"))
(defmethod latex-block-1 ((gi (eql :newpage)) children &key)
(latex-ensure-par)
(write-line "\\pagebreak")
(setf *par-needed-p* t))
(defmethod latex-block-1 ((gi (eql :h1)) children &key)
(latex-ensure-par)
(princ "\\chapter{")
(mapc #'latex-inline children)
(write-line "}")
(terpri)
(setf *par-needed-p* nil))
(defmethod latex-block-1 ((gi (eql :h2)) children &key)
(latex-ensure-par)
(princ "\\section{")
(mapc #'latex-inline children)
(write-line "}")
(terpri)
(setf *par-needed-p* nil))
(defmethod latex-block-1 ((gi (eql :h2*)) children &key)
(latex-ensure-par)
(princ "\\section*{")
(mapc #'latex-inline children)
(write-line "}")
(terpri)
(setf *par-needed-p* nil))
(defmethod latex-block-1 ((gi (eql :h3)) children &key)
(latex-ensure-par)
(princ "\\subsection{")
(mapc #'latex-inline children)
(write-line "}")
(terpri)
(setf *par-needed-p* nil))
(defmethod latex-block-1 ((gi (eql :h4)) children &key)
(latex-ensure-par)
(princ "\\subsubsection{")
(mapc #'latex-inline children)
(write-line "}")
(terpri)
(setf *par-needed-p* nil))
(defmethod latex-block-1 ((gi (eql :p)) children &key)
(latex-ensure-par)
(pprint-logical-block (*standard-output* nil :per-line-prefix " ")
(setf *latex-last-was-white* t)
(mapc #'latex-inline children))
(setf *par-needed-p* t))
(defparameter +verb-filler+ "\\verb||")
(defmethod latex-block-1 ((gi (eql :pre)) children &key)
(latex-ensure-par)
(princ "{\\small")
(princ +verb-filler+) ;trick LaTex to think there is s.th. on the line and not kill the ~'s
(let ((*latex-pre-mode-p* t))
(mapc #'latex-inline children))
(princ "}")
(fresh-line)
(setf *par-needed-p* t))
;;;; -- Defun ---------------------------------------------------------------------------------
(defmethod latex-block-1 ((gi (eql :defun)) children &key name args kind &allow-other-keys)
(latex-ensure-par)
(princ "\\begin{defun}{")
(mapc #'latex-inline name)
(princ "}{")
(mapc #'latex-inline args)
(princ "}{")
(mapc #'latex-inline kind)
(princ "}")
(terpri)
(setf *par-needed-p* nil)
(mapc #'latex-block children)
(fresh-line)
(write-line "\\end{defun}")
(setf *par-needed-p* t))
;;;; -- DL ------------------------------------------------------------------------------------
(defmethod latex-block-1 ((gi (eql :dl)) children &key &allow-other-keys)
(mapc #'latex-block children))
(defmethod latex-block-1 ((gi (eql :dt)) children &key &allow-other-keys)
(terpri)
(terpri)
(mapc #'latex-inline children)
(terpri)
(terpri))
(defmethod latex-block-1 ((gi (eql :dd)) children &key &allow-other-keys)
(write-line "\\begin{list}{}\\item")
(mapc #'latex-block children)
(write-line "\\end{list}"))
;;
(defmethod latex-block-1 ((gi (eql :dl)) children &key &allow-other-keys)
(latex-ensure-par)
(write-line "\\begin{list}{foo}{\\setlength{\\leftmargin}{10em}\\setlength{\\labelwidth}{\\leftmargin}\\advance\\labelwidth-\\labelsep \\setlength{\\itemsep}{0ex}}")
(setf *par-needed-p* nil)
(mapc #'latex-block children)
(fresh-line)
(write-line "\\end{list}")
(setf *par-needed-p* t))
(defmethod latex-block-1 ((gi (eql :dt)) children &key &allow-other-keys)
(latex-ensure-par)
(princ "\\item[")
(setf *latex-last-was-white* t)
(mapc #'latex-inline children)
(princ "\\hfill]"))
(defmethod latex-block-1 ((gi (eql :dd)) children &key &allow-other-keys)
(latex-ensure-par)
(mapc #'latex-block children)
(setf *par-needed-p* t))
;;;; -- UL ------------------------------------------------------------------------------------
(defmethod latex-block-1 ((gi (eql :ul)) children &key &allow-other-keys)
(latex-ensure-par)
(write-line "\\begin{itemize}")
(setf *par-needed-p* nil)
(mapc #'latex-block children)
(fresh-line)
(write-line "\\end{itemize}")
(setf *par-needed-p* t))
(defmethod latex-block-1 ((gi (eql :li)) children &key &allow-other-keys)
(latex-ensure-par)
(princ "\\item ")
(terpri)
(setf *par-needed-p* nil)
(mapc #'latex-block children)
(setf *par-needed-p* t))
;;;; -- figure --------------------------------------------------------------------------------
(defmethod latex-block-1 ((gi (eql :figure)) children &key)
(latex-ensure-par)
(write-line "\\begin{figure}[t]")
(princ "{\\small") ;notwehr
(setf *par-needed-p* nil)
(mapc #'latex-block children)
(fresh-line)
(princ "}")
(write-line "\\end{figure}")
(setf *par-needed-p* t))
(defmethod latex-block-1 ((gi (eql :caption)) children &key &allow-other-keys)
(latex-ensure-par)
(princ "\\caption{")
(setf *latex-last-was-white* t)
(mapc #'latex-inline children)
(princ "}"))
(defmethod latex-block-1 ((gi (eql :blockquote)) children &key &allow-other-keys)
(latex-ensure-par)
(write-line "\\begin{quote}")
(setf *par-needed-p* nil)
(mapc #'latex-block children)
(fresh-line)
(write-line "\\end{quote}")
(setf *par-needed-p* t))
(defmethod latex-block-1 ((gi (eql :center)) children &key &allow-other-keys)
(latex-ensure-par)
(write-line "\\begin{center}")
(setf *par-needed-p* nil)
(mapc #'latex-block children)
(fresh-line)
(write-line "\\end{center}")
(setf *par-needed-p* t))
(defmethod latex-block-1 ((gi (eql :splice)) children &key &allow-other-keys)
(mapc #'latex-block children))
(defmethod latex-block-1 ((gi (eql :div)) children &key &allow-other-keys)
(mapc #'latex-block children))
;;;;
(defmethod latex-inline-1 ((gi (eql :i)) children &key)
(princ "{\\it ")
(mapc #'latex-inline children)
(princ "}"))
(defmethod latex-inline-1 ((gi (eql :b)) children &key)
(princ "{\\bf ")
(mapc #'latex-inline children)
(princ "}"))
(defmethod latex-inline-1 ((gi (eql :tt)) children &key)
(princ "{\\tt ")
(let ((*latex-encoding* :ascii))
(mapc #'latex-inline children))
(princ "}"))
(defmethod latex-inline-1 ((gi (eql :small)) children &key)
(princ "{\\small ")
(mapc #'latex-inline children)
(princ "}"))
(defmethod latex-inline-1 ((gi (eql :big)) children &key)
(princ "{\\huge ")
(mapc #'latex-inline children)
(princ "}"))
(defmethod latex-inline-1 ((gi (eql :splice)) children &key &allow-other-keys)
(mapc #'latex-inline children))
(defmethod latex-inline-1 ((gi (eql :sup)) children &key &allow-other-keys)
(princ "$^{\\mbox{")
(mapc #'latex-inline children)
(princ "}}$"))
(defmethod latex-inline-1 ((gi (eql :footnote)) children &key &allow-other-keys)
(princ "\\footnote{")(terpri)
(let ((*latex-pre-mode-p* nil)
(*latex-last-was-white* t))
(mapc #'latex-block children))
(princ "}"))
(defmethod latex-inline-1 ((gi (eql :entity)) children &key name &allow-other-keys)
(cond ((string= "sdot" name) (princ "$\\cdot$"))
((string= "infin" name) (princ "$\\infty$"))
((string= "pi" name) (princ "$\\pi$"))
((string= "nbsp" name) (princ "~"))
(t
(warn "Entity ~S unknown to LaTeX." name)
)))
(defmethod latex-inline-1 ((gi (eql :tag)) children &key &allow-other-keys)
(warn "Inline tag: ~S." children)
(format t "\\label{~A}" (first children))
)
(defmethod latex-block-1 ((gi (eql :tag)) children &key &allow-other-keys)
(format t "\\label{~A}" (first children))
(setf *par-needed-p* t))
(defmethod latex-inline-1 ((gi (eql :index)) children &key &allow-other-keys)
(format t "\\index{{\\rm ")
(let ((*latex-pre-mode-p* nil) (*latex-last-was-white* t))
(mapc #'latex-inline children))
(princ "}}"))
(defmethod latex-block-1 ((gi (eql :index)) children &key &allow-other-keys)
(latex-inline-1 gi children)
(setf *par-needed-p* t))
(defmethod latex-inline-1 ((gi (eql :ref)) children &key &allow-other-keys)
(format t "\\ref{~A}" (first children))
(setf *latex-last-was-white* nil))
(defmethod latex-inline-1 ((gi (eql :page-ref)) children &key &allow-other-keys)
(format t "\\pageref{~A}" (first children))
(setf *latex-last-was-white* nil))
(defmethod latex-inline-1 (gi children &key &allow-other-keys)
(when (eql gi :P)
(break))
(warn "LATEX inline ~S unknown." gi))
(defmethod latex-block-1 (gi children &key &allow-other-keys)
(warn "LATEX block ~S unknown." gi))
(defun latex-sane-char-p (c)
(or (alphanumericp c)
(find c ".,;/()-:'*=!?+\" ")))
(defun latex-putchar (c)
(case *latex-encoding*
(:ascii
(cond
((member c +white-space+)
(unless *latex-last-was-white*
(princ " ")
(pprint-newline :fill)
(setf *latex-last-was-white* t)))
((latex-sane-char-p c)
(setf *latex-last-was-white* nil)
(princ c))
(t
(setf *latex-last-was-white* nil)
(format t "\\char'~O{}" (char-code c)))))
(t
(cond ((member c '(#\newline #\tab #\space))
(unless *latex-last-was-white*
(princ " ")
(pprint-newline :fill)
(setf *latex-last-was-white* t)))
(t
(setf *latex-last-was-white* nil)
(cond ((latex-sane-char-p c) (princ c))
((find c "#_") (format t "\\~A" c))
((find c "[]\"&`%^~") (format t "\\char'~O{}" (char-code c)))
((find c "<>") (format t "$~A$" c))
((find c "{}") (format t "$\\~A$" c))
((eql c #\_) (format t "{\\tt\\char'137}"))
((eql c #\|) (format t "{\\tt\\char'174}"))
((eql c #\\) (format t "{\\tt\\char'134}"))
(t ;for now
(warn "Unknown char ~S." c)
nil)))))))
(defun latex-text (text)
(cond (*latex-pre-mode-p*
(loop for c across text do
(cond ((eql c #\space) (princ "~"))
((eql c #\newline)
(princ "\\\\")
(terpri)
(princ +verb-filler+))
(t
(latex-putchar c)))))
(t
(loop for c across text do (latex-putchar c)))))
(defun bar ()
(let ((x (convert-block (preprocess-tree (parse-file "zeta-man/manual.ms")))))
(setf x (sanify-white-space x))
(with-open-file (output "zeta-man/a.tex" :direction :output :if-exists :supersede)
(let ((*standard-output* output))
(latex-block x))))
(values))
(defun bar ()
(let ((x (convert-block (preprocess-tree (parse-file "boo.ms")))))
(setf x (sanify-white-space x))
(with-open-file (output "a.tex" :direction :output :if-exists :supersede)
(let ((*standard-output* output))
(latex-block x))))
(values))
(defun chart ()
(loop for code below 256 do
(format t "~O \\char'~O \\\\~%" code code)))