Commit 5746839a authored by Drew Crampsie's avatar Drew Crampsie
Browse files

initial import

;;; -*- lisp -*-
(defsystem :cl-org-mode
((:module :src
:serial t
((:file "packages")
(:file "utils")
(:file "protocol")
(:file "parser")
(:file "cl-org-mode")
:serial t
:depends-on (:alexandria :closer-mop))
This diff is collapsed.
This diff is collapsed.
(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)
(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))
(setf ( node)
(if stack
(make-default-node node next-node stack)
(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 )
: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))
(values nodes next-node)))))
(defmethod read-next-node ((node org-parent-node) (next-node null) stream)
(multiple-value-bind (children new-node)
(read-child-nodes node nil stream)
(when children
(unless (eql (car children) ( node))
;;; Somebody short-circuited the process, namely property-node. why?
(setf children (cons ( node) children))
(setf (node.children node) children)
(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)
(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)
(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))
(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
(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)
)(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
(make-instance (class-of node)
for cons on stack
until (eq cons old-stack)
collect (car cons)))
(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)
(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))
: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)
(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))
(defmethod finalize-node ((node src-node) next-node stack)
(setf ( node) next-node)
(setf (node.text node) (stack->string stack))
next-node)(in-package :cl-org-mode)
(defclass properties-node (delimited-node)
:opening-delimiter ":PROPERTIES:
:closing-delimiter ":END:"))
(defmethod finalize-node ((node properties-node) next-node stack)
(defclass property-node (delimited-node)
((property :initarg :property :accessor
(value :initarg :value :accessor property-node.value))
: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 ( n) key)))
(node.children node))))
(when node (property-node.value node))))
\ No newline at end of file
(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) #\:)
: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
(make-instance (class-of node) :heading (stack->string heading))
(defmethod node-end ((node lisp-docstring-section-node) (next-node lisp-docstring-section-node) stack)
(defmethod node-end ((node lisp-docstring-section-node) (next-node null) stack)
(defmethod print-node ((node lisp-docstring-section-node) &optional stream)
(format stream "*~A*~%~%"(node.heading node))
(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="
(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)))
(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)))
(print-function-syntax (name)
(format stream "*Syntax:*~2/%t/=~(~A~)= "
(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
(let ((function (eval `#',name)))
(print-doc-title function name)
(print-function-syntax name)
(with-output-to-string (s) (print-docstring name type s))
\ No newline at end of file
(defpackage :cl-org-mode
(:use :common-lisp))
\ No newline at end of file
(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))
: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"
(defmethod read-next-node :around (node next-node stream)
(let ((*dispatchers* (node-dispatchers node)))
;(warn "DISPATHERS FOR ~A ~A: ~A" node next-node *dispatchers*)
(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))))))
\ No newline at end of file
(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)
(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))
(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))
\ No newline at end of file
(in-package :cl-org-mode)
(defclass node ()
((next-node :initarg :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 ( starting-node) stream)))
(defgeneric node-start (node stack)
"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)
"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"))
\ No newline at end of file
(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.
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)
(typecase child
(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)
(setf source-file (or (get-property-value properties "source-file") source-file)))
(tangle-org-node child
:source-directory source-directory
:source-file source-file
(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)
\ No newline at end of file
(in-package :cl-org-mode)
(defun stack->string (stack)
(nreverse (coerce stack 'string)))
(defgeneric stack-starts-with (stack maybe-starts-with)
"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))))
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment