qbook generates html formatted code listings of common lisp source files. Comments in the source code are rendered as html paragraphs, text is rendered in <pre> blocks. Headings are created by preceding the text of the comment with one or more #\* chars.
This is inspired by Luke Gorrie's pbook.el.
This is the core of qbook, the driver code which takes a lisp source file and generates an html file.
(defun publish-qbook (file-name &key title output-directory) "Convert FILE-NAME into a qbook html file named OUTPUT-FILE with title TITLE."[...] (unless output-directory (setf output-directory (merge-pathnames "./" *default-pathname-defaults*))) (let ((parts (read-source-file file-name))) (ensure-directories-exist output-directory) (generate-index.html title parts output-directory) (let ((sections '())) (iterate (for p in parts) (if (and (heading-part-p p) (= 1 (depth p))) (push (cons p nil) sections) (push p (car sections)))) (dolist (section (nreverse sections)) (generate-section.html title (nreverse section) output-directory)))))
(defun generate-index.html (title parts output-directory) (with-output-to-file (*yaclml-stream* (merge-pathnames "index.html" output-directory) :if-exists :supersede[...] :if-does-not-exist :create) (<qbook-page :title title (<:h1 :class "title" (<:as-html title)) (<:div :class "contents" (publish-contents parts)))))
(defun generate-section.html (title sections output-directory) (with-output-to-file (*yaclml-stream* (merge-pathnames (make-pathname :name (make-anchor-name (text (first sections)))[...] :type "html") output-directory) :if-does-not-exist :create :if-exists :supersede) (<qbook-page :title title (<:h1 :class "title" (<:as-html title)) (<:div :class "contents") (publish sections))))
(yaclml:deftag-macro <qbook-page (&attribute title &body body) `(<:html (<:head[...] (<:title (<:as-html ,title)) (<:stylesheet "style.css") (<:link :rel "alternate stylesheet" :href "print.css" :title "Print")) (<:body (<:div :class "qbook" ,@body))))
qbook parses lisp code into a list of source-file-part objects. we have an object for code parts (each top level form is considered as a single code object), for comments and for headings.
(defclass source-file-part () ((start-position :accessor start-position :initform nil :initarg :start-position) (end-position :accessor end-position :initform nil :initarg :end-position) (text :accessor text :initform nil :initarg :text) (origin-file :accessor origin-file :initform nil :initarg :origin-file)))
(defclass code-part (source-file-part) ((form :accessor form :initform nil :initarg :form)))
(defclass comment-part (source-file-part) ())
(defgeneric comment-part-p (obj) (:method ((obj t)) nil) (:method ((obj comment-part)) t))
(defclass heading-part (comment-part) ((depth :accessor depth :initarg :depth) (next-part :accessor next-part :initform nil) (prev-part :accessor prev-part :initform nil) (up-part :accessor up-part :initform nil)))
(defmethod print-object ((h heading-part) stream) (print-unreadable-object (h stream :type t :identity nil) (format stream "~D ~S" (depth h) (text h))))
(defgeneric heading-part-p (obj) (:method ((obj t)) nil) (:method ((obj heading-part)) t))
(defclass whitespace-part (source-file-part) ())
(defmethod make-anchor-link ((h heading-part) ) (if (= 1 (depth h)) (strcat (make-anchor-name (text h)) ".html")[...] (labels ((find-level-1 (h) (if (= 1 (depth h)) h (find-level-1 (up-part h))))) (strcat (make-anchor-link (find-level-1 h)) "#" (make-anchor-name (text h))))))
(defun make-anchor-name (text) (regex-replace-all "[^A-Za-z]" text "_"))
(defun publish-contents (parts) (<:ul (iterate[...] (for p in parts) (when (heading-part-p p) (<:div :class (strcat "contents-heading-" (depth p)) (<:a :href (make-anchor-link p) (<:as-html (text p))))))))
(defun publish (parts) (iterate (with state = nil)[...] (for p in parts) (etypecase p (comment-part (setf state (write-comment p state))) (whitespace-part (setf state nil) (<:as-html (text p))) (code-part (setf state (write-code p state))))))
(defun num-lines (text) (iterate (with num-lines = 0)[...] (for char in-string text) (when (member char '(#\Newline #\Return #\Linefeed)) (incf num-lines)) (finally (return num-lines))))
(defun write-code (part state) (ecase state ((nil) nil)[...] (:in-comment (setf state nil) (write-string "</p>" *yaclml-stream*) (terpri *yaclml-stream*))) (let ((text (text part))) (setf text (yaclml::escape-as-html text)) (setf text (regex-replace-all "(\\(|\\))" text "<span class=\"paren\">\\1</span>")) (if (< (num-lines text) 5) (setf text (regex-replace "^.*" text (strcat "<span class=\"first-line\">\\&</span><span class\"body\">"))) (let ((id (strcat "X" (random-string 10)))) (setf text (regex-replace "^(.*)(\\n.*\\n.*)" text (strcat "<span class=\"first-line\">\\1</span>\\2<a class=\"first-line-more-link\" href=\"\" onClick=\"document.getElementById('" id "').style.display = document.getElementById('" id "').style.display == 'none' ? 'inline' : 'none' ; return false;\" />[<b>...</b>]</a><span class=\"body\" id=\"" id "\">"))))) (<:pre :class "code" (<:as-is text) (<:as-is "</span>"))) nil)
(defun write-comment (part state) (etypecase part (heading-part[...] (ecase state ((nil)) (:in-comment ;; heading during a comment, break the current comment ;; and start a new one. (write-string "</p>" *yaclml-stream*) (terpri *yaclml-stream*))) (flet ((heading () (<:a :name (make-anchor-name (text part)) (<:as-html (text part))) (<:as-is " ")) (nav-links () (<:div :class "nav-links" (if (prev-part part) (<:a :class "nav-link" :href (make-anchor-link (prev-part part)) "prev") (<:span :class "dead-nav-link" "prev")) " | " (if (up-part part) (<:a :class "nav-link" :href (make-anchor-link (up-part part)) "up") (<:span :class "dead-nav-link" "up")) " | " (if (next-part part) (<:a :href (make-anchor-link (next-part part)) "next") (<:span :class "nav-link" "next")) " | " (<:a :href "index.html" "toc")))) (case (depth part) (1 (<:h2 (heading))) (2 (<:h3 (heading))) (3 (<:h4 (heading))) (4 (<:h5 (heading))) (5 (<:h6 (heading))) (t (error "Nesting too deep: ~S." (text part)))) (nav-links)) nil) (comment-part ;;;; regular comment (ecase state ((nil) (write-string "<p>" *yaclml-stream*)) (:in-comment nil)) (<:as-html (text part)) :in-comment)))
Directives are a way to control how qbook processes the lisp code. We currently only support the '@include "filename"' directive. @include allows multiple source files to be combined to form a single html file.
(defgeneric process-directive (part))
(defmethod process-directive ((part source-file-part)) (list part))
(defmethod process-directive ((part comment-part)) (declare (special *source-file*)) (multiple-value-bind (matchp strings)[...] (cl-ppcre:scan-to-strings "^@include (.*)" (text part)) (if matchp (return-from process-directive (read-source-file (merge-pathnames (let ((*readtable* (copy-readtable nil))) (read-from-string (aref strings 0))) (truename *source-file*)))) (return-from process-directive (list part)))))
A qbook source file is a lisp source file. Qbook uses the lisp's reader to parse the code (so any valid lisp should be usable). qbook looks for a few things in the lisp file:
1) The code. Each top level form is wrapped in <PRE> tagged as pased through to the HTML. The first line (not form) of the top level form is presented in a bold font. If the form is longer than 3 lines it will be truncated to 3 lines and readers will have to click an the form to see the hidden text.
2) ;;;; Comments - All lines which start with 4 #\; ("^;;;;") and aren't within a top level form are wrapped in a <P> tag and passed through.
3) ; Comments - All comment lines with less than 4 #\; characters are ignored by qbook.
4) @ directives - Lines which start with ;;;;@ are qbook directives. These allow the developer to control how qbook processes the source files. Currently the only supported directive is include.
A decent example of a qbook'd lisp file is qbook itself. qbook.asd contains the include directives which control the order of the sections while the various .lisp files contain qbook comments, qbook headings and ignored comments (every source file contains a copyright message which we don't want to have repeated multiple times in the html)
There is none. You simply can't create tables or produce links or bold text. Patches welcome.
(defun make-part-reader (function type) (lambda (stream echar) (let ((part (make-instance type)))[...] (setf (start-position part) (file-position stream)) (funcall function stream echar) (setf (end-position part) (file-position stream)) part)))
(defun make-qbook-readtable () (iterate (with r = (copy-readtable nil))[...] (for i from 0 below 256) (for char = (code-char i)) (when (get-macro-character char) (multiple-value-bind (function non-terminating-p) (get-macro-character char *readtable*) (set-macro-character char (case char (#\; (make-part-reader function 'comment-part)) (#\( (make-part-reader function 'code-part)) (t (make-part-reader function 'code-part))) non-terminating-p r))) (finally (return r))))
(defun whitespacep (char) (and char (member char '(#\Space #\Tab #\Newline) :test #'char=)))
(defun read-whitespace (stream) (iterate (with part = (make-instance 'whitespace-part))[...] (initially (setf (start-position part) (1+ (file-position stream)))) (while (whitespacep (peek-char nil stream nil nil))) (read-char stream) (finally (setf (end-position part) (file-position stream))) (finally (return-from read-whitespace part))))
(defun process-directives (parts) (iterate (for part in parts) (appending (process-directive part))))
(defun read-source-file (file-name) (let* ((*readtable* (make-qbook-readtable)) (*source-file* file-name)[...] (parts (with-input-from-file (stream file-name) (iterate (for part in-stream stream using #'read) (collect part) (when (whitespacep (peek-char nil stream nil nil)) (collect (read-whitespace stream))))))) (declare (special *source-file*)) (with-input-from-file (stream file-name) (let ((buffer nil)) (dolist (part parts) (file-position stream (1- (start-position part))) (setf buffer (make-array (1+ (- (end-position part) (start-position part))) :element-type 'character)) (read-sequence buffer stream) (setf (text part) buffer (origin-file part) file-name)))) (setf parts (post-process parts) parts (process-directives parts) parts (post-process-navigation parts)) ;; remove all the parts before the first comment part (setf parts (iterate (for p on parts) (until (comment-part-p (first p))) (finally (return p)))) parts))
(defun heading-text-p (text) (scan "^;;;;\\s*\\*+" text))
(defun real-comment-p (text) (scan "^;;;;" text))
(defun post-process (parts) ;; convert all the comments which are acutally headings to heading ;; objects[...] (setf parts (iterate (for p in parts) (typecase p (comment-part (multiple-value-bind (match strings) (scan-to-strings (create-scanner ";;;;\\s*(\\*+)\\s*(.*)" :single-line-mode nil) (text p)) (if match (collect (make-instance 'heading-part :depth (length (aref strings 0)) :text (aref strings 1) :start-position (start-position p) :end-position (end-position p) :origin-file (origin-file p))) (multiple-value-bind (match strings) (scan-to-strings (create-scanner ";;;;(.*)" :single-line-mode t) (text p)) (if match (collect (make-instance 'comment-part :start-position (start-position p) :end-position (end-position p) :text (aref strings 0) :origin-file (origin-file p)))))))) ((or code-part whitespace-part) (collect p))))) ;;;; merge consequtive comments together (setf parts (iterate (with comment = (make-string-output-stream)) (for (p next) on parts) (cond ((heading-part-p p) (collect p)) ((and (comment-part-p p) (or (not (comment-part-p next)) (heading-part-p next) (null next))) (write-string (text p) comment) (collect (make-instance 'comment-part :text (get-output-stream-string comment))) (setf comment (make-string-output-stream))) ((comment-part-p p) (write-string (text p) comment)) (t (collect p))))) parts)
(defun post-process-navigation (parts) ;;;; setup the prev and next links in the header objects (iterate[...] (with last-heading = nil) (for part in parts) (when (heading-part-p part) (when last-heading (setf (prev-part part) last-heading (next-part last-heading) part)) (setf last-heading part))) ;;;; setup the up links (iterate (for (this . rest) on (remove-if-not #'heading-part-p parts)) (iterate (for r in rest) (while (< (depth this) (depth r))) (setf (up-part r) this))) parts)