abstract: CL-ORG-MODE is a parser for org-mode files that uses an extensible CLOS-based recursive descent parser to create a tree of org-mode nodes. Also included is a (primitive) system for literate programming using org-mode
Org-mode is an emacs mode that provides, among other things, an outliner and document authoring system. CL-ORG-MODE is a library for manipulating org-mode files in Common Lisp.
CL-ORG-MODE is still in development, but is already being used to develop itself. Some features:
This document, or possibly the document used to generate this document, is a complete copy of the cl-org-mode source… it just needs extracting, which requires cl-org-mode or some manual labour. If the former idea is more to your liking, get it using git : =git clone http://common-lisp.net/project/cl-org-mode/cl-org-mode.git=
Right now the parser is very simple. The function READ-ORG-FILE will read an org-mode file into a tree of ORG-NODEs.
READ-ORG-FILE
Function READ-ORG-FILE
Syntax:
read-org-file
pathname => result
Description:
Read the org file located at PATHNAME and return an ORG-FILE node.
The literate programming system is very simple at the
moment. Essentially, we recurse through the org-mode nodes. If a
node sets the :source-file: property (C-c C-x p source-file RET filename.lisp RET
), any SOURCE-NODE has its contents inserted in
that file, in the order they appear.
The :source-directory: sets the directory in which the files will be generated. Relative pathnames will be resolved relative to the location of the org-mode file itself.
TANGLE-ORG-NODE
Function TANGLE-ORG-NODE
Syntax:
tangle-org-node
node &key source-directory source-file => result
Arguments and Values:
node—an ORG-NODE source-directory—a pathname, source-file—a pathname. result—returns NIL.
Description:
Walk node and all its children, and print the contents of any SRC-NODE to source-file. If source-file is a relative pathname, it will be merged with source-directory.
If node or any of its children contain :source-file: or :source-directory: properties, they will replace the value of source-file or source-directory for that node and its children. NIL
;;; -*- lisp -*- (defsystem :cl-org-mode :components ((:module :src :serial t :components ((:file "packages") (:file "utils") (:file "protocol") (:file "parser") (:file "cl-org-mode") ))) :serial t :depends-on (:alexandria :closer-mop))
(defpackage :cl-org-mode (:use :common-lisp))
(in-package :cl-org-mode) (defclass node () ((next-node :initarg :next-node :accessor node.next-node :initform nil)) (:documentation "Base class for all nodes")) (defvar *dispatchers* nil "A dynamic variable to hold a list of nodes to use as dispatchers. The default method for FIND-NEXT-NODE will call NODE-START on these nodes") (defgeneric node-dispatchers (node) (:documentation "Called by the reader in order to set the dynamic dispatch environment before reading the next node")) (defgeneric find-next-node (node next-node stack) (:documentation "Find the next node that starts in STREAM, implicitly ending NODE. All methods must return the multiple values (VALUES NEW-NODE OLD-STACK) as if from NODE-START. ")) (defgeneric read-next-node (node next-node stream) (:documentation "read the next node in stream and return it. This is the main entry point for specializing node types.")) (defgeneric read-node (starting-node stream) (:documentation "return the next node after reading it from the stream The default method simply calls READ-NEXT-NODE.") (:method (starting-node stream) (read-next-node starting-node (node.next-node starting-node) stream))) (defgeneric node-start (node stack) (:documentation "Indicate a new node should begin at this point in the stack. The parser will pass a class prototype instance via NODE, so it shouldn't be mutated. All methods _must_ return (VALUES NEW-NODE OLD-STACK) where NEW-NODE created NODE object and any remaining stack which likely belongs to the previous node.")) (defgeneric node-end (node next-node stack) (:documentation "return true if stack of characters indicate this node has finished reading")) (defgeneric finalize-node (node next-node stack) (:documentation "Called when the node has finished reading. This is usually either because node-end returned true or implicitly because another node has started"))
(in-package :cl-org-mode) (defmethod read-next-node (node (next-node null) stream) "This method is called when we don't yet know what the next node is" (let (stack) (loop for char = (read-char stream nil) :if (null char) :do (return (finalize-node node NIL stack)) :else :do (push char stack) (multiple-value-bind (new-node old-stack) (find-next-node node next-node stack) (when new-node (return (finalize-node node new-node old-stack))))))) (defmethod read-next-node (node (next-node node) stream) "When we know what the node is already, just return it" next-node) (defmethod read-next-node :around (node next-node stream) (let ((*dispatchers* (node-dispatchers node))) ;(warn "DISPATHERS FOR ~A ~A: ~A" node next-node *dispatchers*) (call-next-method))) (defmethod find-next-node (node next-node stack) (loop for object in *dispatchers* :do (multiple-value-bind (result old-stack) (node-start object stack) (when result (return (values result old-stack))))))
(in-package :cl-org-mode) (defclass org-node (node) ()) (defmethod node-start ((node org-node) stream) nil) (defmethod node-end ((node org-node) next-node stream) nil) (defmethod node-end ((node org-node) (next-node null) stack) T) (defmethod node-dispatchers ((node org-node)) (or *dispatchers* (mapcar #'make-instance '(src-node properties-node outline-node)))) (defmethod node-prototypes (node) (error "never call")) (defmethod finalize-node (node next-node stack) "If there is something on the stack, and a new node has started, then stick it in the default node" ; (break "Finalizing ~A ~A ~A ~A" node next-node stack (node.next-node node)) (setf (node.next-node node) (if stack (make-default-node node next-node stack) next-node))) (defgeneric make-default-node (node next-node stack) (:documentation "Anything not in another node ends up here") (:method ((node org-node) next-node stack) ; (break "Making default: ~A ~A ~A" node next-node stack) (make-instance 'text-node :text (stack->string stack) :next-node next-node))) (defclass text-node (org-node) ((text :initarg :text :accessor node.text)))
(in-package :cl-org-mode) (defclass org-parent-node (org-node) ((child-nodes :initarg :children :accessor node.children :initform nil) (include-end-node :initarg :include-end-node :initform nil :reader include-end-node-p)) (:documentation "Some node contain other nodes")) (defun read-child-nodes (root-node stack stream ) (loop :for next-node = (read-node root-node stream) :then (and next-node (read-node next-node stream)) :until (node-end root-node next-node stack) ;:do (warn "reading root ~A : next-node : ~A ~A" root-node next-node stack) :collect next-node into nodes :finally (return (if (include-end-node-p root-node) (values (nconc nodes (list next-node)) next-node) (values nodes next-node))))) (defmethod read-next-node ((node org-parent-node) (next-node null) stream) (call-next-method) (multiple-value-bind (children new-node) (read-child-nodes node nil stream) (when children (unless (eql (car children) (node.next-node node)) ;;; Somebody short-circuited the process, namely property-node. why? (setf children (cons (node.next-node node) children)) )) (setf (node.children node) children) new-node)) (defmethod read-node :around ((node org-parent-node) stream) (let ((new-node (call-next-method))) (if (include-end-node-p node) (read-node new-node stream) new-node))) (defun read-parent-node (parent-node stream) (read-node parent-node stream) parent-node) (defclass org-file (org-parent-node) ((pathname :accessor node.pathname :initarg :pathname))) (defun read-org-file (pathname) (let ((node (make-instance 'org-file :pathname pathname))) (alexandria:with-input-from-file (stream pathname) (read-parent-node node stream))))
(in-package :cl-org-mode) (defclass delimited-node (org-parent-node) ((opening-delimiter :initarg :opening-delimiter :accessor node.opening-delimiter :initform nil) (closing-delimiter :initarg :closing-delimiter :accessor node.closing-delimiter :initform nil) (closing-delimiter-node :accessor node.closing-delimiter-node) (node-closed :initform nil :accessor node.closed-p)) (:default-initargs :include-end-node t)) (defclass closing-delimiter-node (org-node) ((opening-delimiter-node :accessor node.opening-delimiter-node :initarg :opening-delimiter-node))) (defmethod shared-initialize :after ((node delimited-node) slots &rest args) (declare (ignore args)) (setf (node.closing-delimiter-node node) (make-instance 'closing-delimiter-node :opening-delimiter-node node))) (defmethod node-dispatchers ((node delimited-node)) (if (node.closed-p node) (call-next-method) (cons (node.closing-delimiter-node node) (call-next-method)))) (defmethod node-start ((node delimited-node) stack) (with-slots (opening-delimiter) node (when opening-delimiter (multiple-value-bind (delimiter old-stack) (stack-starts-with stack opening-delimiter) (when delimiter (values (make-instance (class-of node) :opening-delimiter (stack->string delimiter)) old-stack)))))) (defmethod node-start ((node closing-delimiter-node) stack) (with-slots (closing-delimiter) (node.opening-delimiter-node node) (multiple-value-bind (indicator old-stack) (stack-starts-with stack closing-delimiter) (when indicator (values node old-stack))))) (defmethod node-end ((node delimited-node) (next-node closing-delimiter-node) stack) (when (eq next-node (node.closing-delimiter-node node)) (setf (node.closed-p node) t))) (defmethod read-next-node :around ((node delimited-node) next-node stream) (call-next-method) )
(in-package :cl-org-mode) (defclass outline-node (org-parent-node) ((heading :accessor node.heading :initform nil :initarg :heading) (heading-level-indicator :accessor node.heading-level-indicator :initform nil :initarg :indicator))) (defun at-outline-node-p (stack) (let ((char (first stack)) (stack (rest stack))) (and (eql char #\space) (eql (first stack) #\*) (if (or (null (rest stack)) (eql #\Newline (second stack))) (values t (rest stack)) (at-outline-node-p (cons char (rest stack))))))) (defmethod node-start ((node outline-node) stack) (multiple-value-bind (pred old-stack) (at-outline-node-p stack) (if pred (values (make-instance (class-of node) :indicator (loop for cons on stack until (eq cons old-stack) collect (car cons))) old-stack)))) (defmethod node-end ((node outline-node) (next-node outline-node) stack) (<= (length (node.heading-level-indicator next-node)) (length (node.heading-level-indicator node)))) (defmethod node-end ((node outline-node) (next-node null) stack) t) (defmethod read-next-node ((node outline-node) (next-node null) stream) (setf (node.heading node) (read-line stream nil)) (call-next-method))
(in-package :cl-org-mode) (defclass src-node (delimited-node text-node) ((emacs-mode :initarg :emacs-mode :accessor node.emacs-mode :initform nil)) (:default-initargs :opening-delimiter "#+BEGIN_SRC" :closing-delimiter (format nil "~%#+END_SRC") :text nil :include-end-node nil)) (defmethod node-dispatchers ((node src-node)) (if (node.text node) (call-next-method) (list (node.closing-delimiter-node node)))) (defmethod read-next-node ((node src-node) (next-node null) stream) (setf (node.emacs-mode node) (read-line stream nil)) (call-next-method)) (defmethod finalize-node ((node src-node) next-node stack) (setf (node.next-node node) next-node) (setf (node.text node) (stack->string stack)) next-node)
(in-package :cl-org-mode) (defclass properties-node (delimited-node) () (:default-initargs :opening-delimiter ":PROPERTIES: " :closing-delimiter ":END:")) (defmethod finalize-node ((node properties-node) next-node stack) (call-next-method)) (defclass property-node (delimited-node) ((property :initarg :property :accessor property-node.property) (value :initarg :value :accessor property-node.value)) (:default-initargs :closing-delimiter (format nil "~%"))) (defmethod node-start ((node property-node) stack) (let ((pos (position #\: (cdr stack)))) (when (and pos (eql #\: (car stack))) (let ((property (nreverse (coerce (subseq (cdr stack) 0 pos) 'string )))) (when property (values (make-instance (class-of node) :property property) (subseq (cddr stack) pos))))))) (defmethod finalize-node ((node property-node) next-node stack) (setf (property-node.value node) (nreverse (coerce (butlast stack) 'string))) (call-next-method node next-node (cons (first stack ) (last stack)))) (defmethod node-dispatchers ((node properties-node)) (let ((dispatchers (call-next-method))) (list (node.closing-delimiter-node node) (make-instance 'property-node) ))) (defun get-property-value (node key) (let ((node (find-if (lambda (n) (and (typep n 'property-node) (equal (property-node.property n) key))) (node.children node)))) (when node (property-node.value node))))
**
(in-package :cl-org-mode) (defgeneric print-node (node &optional stream) (:documentation "Print text serialization of node.") (:method :around (node &optional (stream *standard-output*)) (call-next-method node stream))) (defmethod print-node :around ((node delimited-node) &optional stream) (write-sequence (node.opening-delimiter node) stream) (call-next-method)) (defmethod print-node ((node closing-delimiter-node) &optional stream) (princ (node.closing-delimiter (node.opening-delimiter-node node)) stream)) (defmethod print-node :around ((node outline-node) &optional stream) (format stream "~A~A~%" (stack->string (node.heading-level-indicator node)) (node.heading node)) (call-next-method)) (defmethod print-node ((node property-node) &optional stream) (with-slots (property value) node (format stream ":~A: ~A~%" property value))) (defmethod print-node ((node src-node) &optional stream) (format stream "~A~%"(node.emacs-mode node)) (write-sequence (node.text node) stream))
(in-package :cl-org-mode) (defun stack->string (stack) (nreverse (coerce stack 'string))) (defgeneric stack-starts-with (stack maybe-starts-with) (:documentation "return (values start-of-stack rest-of-stack) if stack starts with maybe-starts-with. If maybe-starts-with is a string. reverse it before testing against stack") (:method (stack list) ;; there are better ways to do this i'm sure. (let ((does-it? (when (>= (length stack)(length list)) (loop :for cons on stack :for pair on list :always (eql (car cons) (first pair)))))) (when does-it? (values list (nthcdr (length list) stack))))) (:method (stack (string string)) (stack-starts-with stack (coerce (reverse string) 'list))))
(in-package :cl-org-mode) (defun tangle-org-node (node &key (source-directory (node.pathname node)) source-file) "Arguments and Values: node---an ORG-NODE source-directory---a pathname, source-file---a pathname. result---returns NIL. Description: Walk node and all its children, and print the contents of any SRC-NODE to source-file. If source-file is a relative pathname, it will be merged with source-directory. If node or any of its children contain :source-file: or :source-directory: properties, they will replace the value of source-file or source-directory for that node and its children." (flet ((tangle () (loop for child in (node.children node) :do (typecase child (outline-node (let ((properties (find-if (lambda (x) (typep x 'properties-node)) (node.children child)))) (when properties (setf source-directory (let ((path (get-property-value properties "source-directory"))) (if path (if (eq :RELATIVE (first (pathname-directory path))) (merge-pathnames path source-directory) path) source-directory))) (setf source-file (or (get-property-value properties "source-file") source-file))) (tangle-org-node child :source-directory source-directory :source-file source-file ))) (src-node (if (streamp source-file) (write-sequence (node.text child) source-file) (warn "Source node has no stream"))))))) (if (and source-file (not (streamp source-file))) (alexandria:with-output-to-file (stream (merge-pathnames source-file source-directory) :if-exists :supersede :if-does-not-exist :create) (setf source-file stream) (tangle)) (tangle))))
(in-package :cl-org-mode) (defclass lisp-docstring (org-parent-node) ()) (defmethod node-dispatchers :around ((node lisp-docstring)) (mapcar #'make-instance '(lisp-docstring-section-node))) (defclass lisp-docstring-section-node (lisp-docstring) ((heading :accessor node.heading :initform nil :initarg :heading))) (defun section-node-start-p (stack) (when (and (eql #\Newline (first stack)) (eql #\Newline (second stack)) (eql (third stack) #\:)) (break "~A second stack" (char-name (Second stack))) (let ((stack (cddr stack))) (and (eql (first stack) #\:) (loop :for (char . chars) on stack :collect char into heading :if (and (or (null chars) (and (eql (first chars) #\Newline) (eql (second chars) #\Newline))) (alpha-char-p char)) :do (return (values heading chars))))))) (defmethod node-start ((node lisp-docstring-section-node) stack) (multiple-value-bind (heading old-stack) (section-node-start-p stack) (if heading (values (make-instance (class-of node) :heading (stack->string heading)) old-stack)))) (defmethod node-end ((node lisp-docstring-section-node) (next-node lisp-docstring-section-node) stack) t) (defmethod node-end ((node lisp-docstring-section-node) (next-node null) stack) t) (defmethod print-node ((node lisp-docstring-section-node) &optional stream) (format stream "*~A*~%~%"(node.heading node)) (call-next-method)) (defun parse-docstring (string) (with-input-from-string (stream string) (read-parent-node (make-instance 'lisp-docstring) stream)))
(in-package :cl-org-mode) (defun print-docstring (name type stream) (let ((docstring (parse-docstring (documentation name type)))) (if (typep (first (node.children docstring)) 'lisp-docstring-section-node) (print-node docstring stream) (progn (format stream "*Description:*~%") (print-node docstring stream))))) (defun print-doc-title (object name stream) (format stream "/~A/ " (split-sequence:split-sequence #\- (princ-to-string (type-of object)))) (format stream "=~a=" name)) (defun newline-and-indent (stream depth &optional (num 1) (char #\Space) (newline #'terpri)) (dotimes (n num) (funcall newline stream) (dotimes (n depth) (princ char stream)) (princ #\Space stream))) (defun cl-user::%t (stream arg colon at &rest parameters) (if (listp arg) (destructuring-bind (depth char) arg (newline-and-indent stream depth (or (first parameters) 1) char (if colon #'fresh-line #'terpri))) (newline-and-indent stream arg (or (first parameters) 1)))) (defun convert-newline-to-indent (string indent-level output-stream) (map nil (lambda (char) (if (eql char #\newline) (format output-stream "~/%t/" indent-level) (princ char output-stream))) string)) (defun print-lisp-documentation-to-org-node (spec stream &key (starting-depth 2)) (flet ((p () (format stream "~2/%t/" starting-depth)) (print-doc-title (object name) (format stream "~:/%t/~@?~2/%t/~4:*~@?" `(,starting-depth #\*) "/~:(~{~A~^ ~}~)/ =~A=" (split-sequence:split-sequence #\- (princ-to-string (type-of object))) name starting-depth)) (print-function-syntax (name) (format stream "*Syntax:*~2/%t/=~(~A~)= " starting-depth name) (dolist (arg (swank::arglist name)) (and (listp arg) (setf arg (car arg))) (format stream (if (and (symbolp arg) (eql (aref (symbol-name arg) 0) #\&)) "/~(~A~)/ " "~(~A~) ") arg) ) (format stream "=> /result/"))) (if (listp spec) (destructuring-bind (type name) spec (case type (function (let ((function (eval `#',name))) (print-doc-title function name) (p) (print-function-syntax name) (p) (convert-newline-to-indent (with-output-to-string (s) (print-docstring name type s)) starting-depth stream)))) ))))
Date: 2009-12-01 12:10:19 PST
HTML generated by org-mode 6.21b in emacs 23