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.
(defpackage :qbook (:use :common-lisp :arnesi[...] :iterate :cl-ppcre :yaclml))
(in-package :qbook)
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)))
(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)))
(defgeneric heading-part-p (obj) (:method ((obj t)) nil) (:method ((obj heading-part)) t))
(defclass whitespace-part (source-file-part) ())
We currently only support one directive '@include "filename"'. This include directive 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))) *source-file*))) (return-from process-directive (list part)))))
(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)))) (setf parts (post-process parts)) (setf parts (process-directives 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))) (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)))))))) ((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)
This code converts a list of source-file-part objects into a single html file.
(defun publish-qbook (file-name &key title output-file) "Convert FILE-NAME into a qbook html file named OUTPUT-FILE with title TITLE."[...] (unless output-file (setf output-file (make-pathname :type "html" :defaults file-name))) (let ((parts (read-source-file file-name))) (with-output-to-file (*yaclml-stream* output-file :if-exists :supersede :if-does-not-exist :create) (<:html (<:head (<:title (<:as-html title)) (<:stylesheet "style.css")) (<:body (<:h1 :class "title" (<:as-html title)) (<:div :class "contents" (publish-contents parts)) (let ((*in-comment* nil) (*header-depth* 1) (*headers* '())) (declare (special *in-comment* *headers* *header-depth*)) (publish parts)))))))
(defun make-anchor-link (text) (strcat "#" (make-anchor-name text)))
(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 (concatenate 'string "contents-heading-" (princ-to-string (depth p))) (<:a :href (make-anchor-link (text 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 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>")) (let ((id (strcat "X" (random-string 10)))) (setf text (regex-replace "^.*" text (strcat " <a class=\"first-line\" href=\"\" onClick=\"document.getElementById('" id "').style.display = document.getElementById('" id "').style.display == 'none' ? 'inline' : 'none' ; return false;\"/>\\&</a><span class=\"body\" id=\"" id "\" style=\"display: none\">")))) (<: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))))) (case (depth part) (0 (<:h2 (heading))) (1 (<:h3 (heading))) (2 (<:h4 (heading))) (3 (<:h5 (heading))) (4 (<:h6 (heading))) (t (error "Nesting too deep: ~S." (text part))))) nil) (comment-part ;;;; regular comment (ecase state ((nil) (write-string "<p>" *yaclml-stream*)) (:in-comment nil)) (<:as-html (text part)) :in-comment)))