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

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.

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

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

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

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

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