CL-ORG-MODE : A Parser of org-mode outlines

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

Table of Contents

1 Introduction

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.

1.1 Features

CL-ORG-MODE is still in development, but is already being used to develop itself. Some features:

  • An extensible parser with a concrete implementation for a subset of org-mode features.
  • A simple literate programming like system for writing Common Lisp code inside org mode.

1.2 Planned Features

  • Better integration with slime (the package issue).
  • Extensible printer to go with the parser.
  • 'round trip' from source files to org-mode nodes, so changes in generated .lisp files end up in the .org.

2 Finding and Installing

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 :

3 CL-ORG-MODE Documentation

3.1 The Parser

3.1.1 Parser Concepts

Right now the parser is very simple. The function READ-ORG-FILE will read an org-mode file into a tree of ORG-NODEs.

3.1.2 Parser Dictionary

  • Function 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.

3.2 Org Nodes

3.2.1 Org Node Concepts

3.2.2 Org Node Dictionary

3.3 The Literate Programming System

3.3.1 Literate Programming Concepts

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.

3.3.2 Literate Programming Dictionary

  • Function 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

4 CL-ORG-MODE : The Source Code

4.1 The CL-ORG-MODE system definition

;;; -*- 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))

4.2 CL-ORG-MODE Package

(defpackage :cl-org-mode 
  (:use :common-lisp))

4.3 The Parser Protocol

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

4.4 The Parser

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

4.5 An implementation of the protocol for org-mode files

4.5.1 The ORG-NODE base class + default text node

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

4.5.2 ORG-PARENT-NODE : for nodes that have children, + ROOT-NODE.

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

4.5.3 DELIMITED-NODE

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

4.5.4 OUTLINE-NODE : Used for org-mode outlines

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

4.5.5 SRC-NODE : Make blocks out of BEGINSRC nodes.

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

4.5.6 PROPERTIES-NODE: Capture the :PROPERTIES drawer

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

**

4.6 A printer for org-nodes

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

4.7 Utilities

  • Note taken on 2009-11-28 Sat 15:24
    (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))))
    

5 ORG-LITERATE-PROGRAMMING Source Code

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

6 ORG-LISP-DOCUMENTATION

6.1 Doctstring parsing

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

6.2 Print lisp documentation

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

Author: Drew Crampsie <Drew Crampsie >

Date: 2009-12-01 12:10:19 PST

HTML generated by org-mode 6.21b in emacs 23