(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)))