origami.el/origami.el

429 lines
17 KiB
EmacsLisp
Raw Normal View History

2014-03-18 06:23:46 +11:00
;;; origami.el --- Flexible text folding -*- lexical-binding: t -*-
;; Author: Greg Sexton <gregsexton@gmail.com>
;; Version: 1.0
;; Keywords: folding
;; URL: https://github.com/gregsexton/
;; Package-Requires: ((s "1.9.0") (dash "2.5.0") (emacs "24"))
2014-03-18 06:23:46 +11:00
;; The MIT License (MIT)
;; Copyright (c) 2014 Greg Sexton
;; Permission is hereby granted, free of charge, to any person obtaining a copy
;; of this software and associated documentation files (the "Software"), to deal
;; in the Software without restriction, including without limitation the rights
;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;; copies of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
;; THE SOFTWARE.
;;; Commentary:
;;; Code:
(require 'dash)
(require 's)
2014-03-18 06:23:46 +11:00
;;; fold structure
(defun origami-fold-node (beg end open &optional children data)
(let ((sorted-children (-sort (lambda (a b)
(or (< (origami-fold-beg a) (origami-fold-beg b))
(and (= (origami-fold-beg a) (origami-fold-beg b))
(< (origami-fold-end a) (origami-fold-end b)))))
(remove nil children))))
;; ensure invariant: no children overlap
(when (-some? (lambda (pair)
(let ((a (car pair))
(b (cadr pair)))
(when b ;for the odd numbered case - there may be a single item
;; the < function doesn't support varargs
(or (>= (origami-fold-beg a) (origami-fold-end a))
(>= (origami-fold-end a) (origami-fold-beg b))
(>= (origami-fold-beg b) (origami-fold-end b))))))
(-partition-all-in-steps 2 1 sorted-children))
(error "Tried to construct a node where the children overlap or are not distinct regions: %s"
sorted-children))
;; ensure invariant: parent encompases children
(let ((beg-children (origami-fold-beg (car sorted-children)))
(end-children (origami-fold-end (-last-item sorted-children))))
(if (and beg-children (or (> beg beg-children) (< end end-children)))
(error "Node does not overlap children in range. beg=%s end=%s beg-children=%s end-children=%s"
beg end beg-children end-children)
(vector beg end open sorted-children data)))))
(defun origami-fold-top-level-node (&optional children)
;; TODO: fix min and max
(origami-fold-node 1 10000 t children))
2014-03-18 06:23:46 +11:00
(defun origami-fold-beg (node) (when node (aref node 0)))
2014-03-18 07:25:10 +11:00
(defun origami-fold-end (node) (when node (aref node 1)))
2014-03-18 07:25:10 +11:00
(defun origami-fold-open-p (node) (when node (aref node 2)))
2014-03-18 07:25:10 +11:00
(defun origami-fold-open-set (path value)
(let* ((old-node (-last-item path))
(new-node (origami-fold-node (origami-fold-beg old-node)
(origami-fold-end old-node)
value
(origami-fold-children old-node)
(origami-fold-data old-node))))
(origami-fold-assoc path new-node)))
2014-04-14 06:08:02 +10:00
(defun origami-fold-children (node &optional children)
(when node
(if children
(origami-fold-node (origami-fold-beg node)
(origami-fold-end node)
(origami-fold-open-p node)
children
(origami-fold-data node))
(aref node 3))))
2014-03-18 07:25:10 +11:00
2014-03-18 06:23:46 +11:00
(defun origami-fold-data (node &optional data)
"With optional param DATA, add or replace data. This cannot be
used to nil out data. This mutates the node."
(when node
(if data
(aset node 4 data)
(aref node 4))))
2014-03-18 06:23:46 +11:00
2014-03-18 07:23:57 +11:00
(defun origami-fold-range-equal (a b)
2014-03-18 06:23:46 +11:00
(and (equal (origami-fold-beg a) (origami-fold-beg b))
2014-03-18 07:23:57 +11:00
(equal (origami-fold-end a) (origami-fold-end b))))
2014-03-18 06:23:46 +11:00
2014-03-18 07:23:57 +11:00
(defun origami-fold-state-equal (a b)
(equal (origami-fold-open-p a) (origami-fold-open-p b)))
(defun origami-fold-replace-child (node old new)
(origami-fold-children node
(cons new (remove old (origami-fold-children node)))))
2014-04-14 06:08:02 +10:00
(defun origami-fold-assoc (path new-node)
"Rewrite the tree, replacing the node referenced by path with NEW-NODE"
(cdr
(-reduce-r-from (lambda (node acc)
(destructuring-bind (old-node . new-node) acc
(cons node (origami-fold-replace-child node old-node new-node))))
(cons (-last-item path) new-node)
(butlast path))))
2014-04-14 06:08:02 +10:00
2014-03-18 07:23:57 +11:00
(defun origami-fold-diff (old new on-add on-remove on-change)
(cl-labels ((diff-children (old-children new-children)
(let ((old (car old-children))
(new (car new-children)))
(cond ((null old) (-each new-children on-add))
((null new) (-each old-children on-remove))
((and (null old) (null new)) nil)
((origami-fold-range-equal old new)
(origami-fold-diff old new on-add on-remove on-change)
(diff-children (cdr old-children) (cdr new-children)))
((<= (origami-fold-beg old) (origami-fold-beg new))
(funcall on-remove old)
(diff-children (cdr old-children) new-children))
(t (funcall on-add new)
(diff-children old-children (cdr new-children)))))))
(unless (origami-fold-range-equal old new)
(error "Precondition invalid: old must have the same range as new."))
(unless (origami-fold-state-equal old new)
(funcall on-change old new))
(diff-children (origami-fold-children old)
(origami-fold-children new))))
2014-03-18 06:23:46 +11:00
(defun origami-fold-postorder-each (node f)
(-each (origami-fold-children node) f)
(funcall f node))
(defun origami-fold-find-deepest (tree pred)
(when tree
(when (funcall pred tree)
(-if-let (child (-first pred (origami-fold-children tree)))
(cons tree (origami-fold-find-deepest child pred))
(list tree)))))
(defun origami-fold-find-node-with-range (tree beg end)
"Return the path to the most specific (deepest) node that has
exactly the range BEG-END, or null."
(-when-let (path (origami-fold-find-deepest tree
(lambda (node)
(and (>= beg (origami-fold-beg node))
(<= end (origami-fold-end node))))))
(let ((last (-last-item path)))
(when (and (= beg (origami-fold-beg last))
(= end (origami-fold-end last)))
path))))
(defun origami-fold-find-node-containing (tree point)
"Return the path to the most specific (deepest) node that
contains point, or null."
(origami-fold-find-deepest tree
(lambda (node)
(and (<= (origami-fold-beg node) point)
(>= (origami-fold-end node) point)))))
2014-03-18 06:23:46 +11:00
;;; overlay manipulation
2014-03-18 07:23:57 +11:00
(defun origami-create-overlay (beg end buffer text)
2014-03-18 06:23:46 +11:00
(let ((ov (make-overlay beg end buffer)))
(overlay-put ov 'invisible 'origami)
;; TODO: make this customizable
(overlay-put ov 'display text)
(overlay-put ov 'face 'font-lock-comment-delimiter-face)
ov))
2014-03-18 07:23:57 +11:00
(defun origami-create-overlay-for-node (node buffer)
(let ((overlay (origami-create-overlay (origami-fold-beg node)
(origami-fold-end node) buffer "...")))
(origami-fold-data node overlay)))
(defun origami-create-overlay-from-fold-tree-fn (buffer)
2014-03-18 06:23:46 +11:00
(lambda (node)
(origami-fold-postorder-each
node (lambda (n)
2014-03-18 07:23:57 +11:00
(when (not (origami-fold-open n))
(origami-create-overlay-for-node n buffer))))))
2014-03-18 06:23:46 +11:00
2014-03-18 07:23:57 +11:00
(defun origami-delete-overlay-from-fold-tree-fn (buffer)
2014-03-18 06:23:46 +11:00
(lambda (node)
(origami-fold-postorder-each
node (lambda (node)
(-when-let (ov (origami-fold-data node))
(delete-overlay ov))))))
2014-03-18 07:23:57 +11:00
(defun origami-change-overlay-from-fold-node-fn (buffer)
(lambda (old new)
(if (origami-fold-open-p new)
(delete-overlay (origami-fold-data old))
(origami-create-overlay-for-node new buffer))))
2014-03-18 06:23:46 +11:00
(defun origami-remove-all-overlays (buffer)
;; TODO:
)
;;; content structure
(defun origami-content (consumed string)
"Create a content structure from STRING and the count of CONSUMED characters."
(cons consumed string))
(defun origami-content-consumed-count (content) (car content))
(defun origami-content-string (content) (cdr content))
(defun origami-content-from (content consumed)
"Create a new content after consuming CONSUMED chars."
(origami-content (+ (origami-content-consumed-count content) consumed)
(substring (origami-content-string content) consumed)))
2014-04-14 06:08:02 +10:00
;;; monadic parser combinator
2014-03-26 09:00:34 +11:00
(defun origami-run-parser (parser content)
(funcall parser content))
(defun origami-parser-bind (m f)
"State monad composed with the maybe monad."
2014-03-26 09:00:34 +11:00
(if (null m) nil
(lambda (s)
2014-03-26 09:00:34 +11:00
(let ((new-result (origami-run-parser m s)))
(if (null new-result) nil
(destructuring-bind (new-value . new-state) new-result
2014-03-26 09:00:34 +11:00
(origami-run-parser (funcall f new-value) new-state)))))))
(defmacro origami-do (expr &rest more)
(let ((assignment-p (and (listp expr) (equal (cadr expr) '<-))))
(let ((var (if assignment-p (car expr) (gensym)))
(f (if assignment-p (caddr expr) expr)))
(if more
`(origami-parser-bind
,f (lambda (,var)
(origami-do ,@more)))
f))))
(defun origami-parser-return (x)
(lambda (s) (cons x s)))
2014-03-26 09:00:34 +11:00
(defun origami-parser-zero ()
(lambda (s) nil))
2014-03-26 09:00:34 +11:00
(defun origami-parser-get ()
(lambda (s) (cons s s)))
2014-03-26 09:00:34 +11:00
(defun origami-parser-item ()
(lambda (content)
2014-03-26 09:00:34 +11:00
(let ((content-str (origami-content-string content)))
(unless (s-blank? content-str)
(cons (substring content-str 0 1) (origami-content-from content 1))))))
(defun origami-parser-position ()
"Returns the point position, which is 1 more than the current
consumed count."
2014-03-26 09:00:34 +11:00
(origami-do (content <- (origami-parser-get))
(origami-parser-return (+ (origami-content-consumed-count content) 1))))
2014-03-26 09:00:34 +11:00
2014-04-14 05:24:33 +10:00
(defun origami-parser-sat (pred)
2014-03-26 09:00:34 +11:00
(origami-do (pos <- (origami-parser-position))
(a <- (origami-parser-item))
2014-04-14 05:24:33 +10:00
(if (funcall pred a)
2014-03-26 09:00:34 +11:00
(origami-parser-return pos)
(origami-parser-zero))))
(defun origami-parser-char (x)
(origami-parser-sat (lambda (c) (equal x c))))
2014-04-14 05:24:33 +10:00
(defun origami-parser-conj (p1 p2)
(lambda (content)
(or (origami-run-parser p1 content)
(origami-run-parser p2 content))))
2014-03-26 09:00:34 +11:00
2014-04-14 05:24:33 +10:00
(defun origami-parser-0+ (p)
(origami-parser-conj
(origami-parser-1+ p)
(origami-parser-return nil)))
(defun origami-parser-1+ (p)
2014-04-08 06:50:39 +10:00
;; recursive isn't going to cut it in elisp
(lambda (content)
(let ((res (origami-run-parser p content))
(acc nil))
(while res
(setq acc (cons (car res) acc))
2014-04-14 05:24:33 +10:00
(setq content (cdr res))
(setq res (origami-run-parser p content)))
(when acc
(cons (reverse acc) content)))))
2014-04-08 06:50:39 +10:00
2014-04-14 05:24:33 +10:00
(defun origami-parser-1? (p)
(origami-parser-conj p (origami-parser-return nil)))
(defun origami-parser-paired (start end children is-open data)
2014-04-14 05:24:33 +10:00
(origami-do (begin <- start)
(children <- (origami-parser-0+ children))
(end <- end)
(origami-parser-return (origami-fold-node begin end
(funcall is-open begin end)
children
(funcall data begin end)))))
2014-04-14 05:24:33 +10:00
(defun origami-parser-consume-while (pred)
(origami-do (positions <- (origami-parser-1+ (origami-parser-sat pred)))
(origami-parser-return (car (last positions)))))
2014-04-11 05:25:30 +10:00
2014-04-14 06:08:02 +10:00
;;; TODO: always need to parse to max nesting, even if some of it gets ignored
;;; interactive utils
;;; TODO: delete or make buffer local
(defvar origami-tree (origami-fold-top-level-node))
2014-04-14 06:08:02 +10:00
(defun origami-get-cached-tree (buffer)
;; TODO:
(debug-msg "old tree: %s" origami-tree)
origami-tree)
2014-04-14 06:08:02 +10:00
(defun origami-store-cached-tree (buffer tree)
;; TODO:
(debug-msg "new tree: %s" tree)
(setq origami-tree tree))
2014-04-14 06:08:02 +10:00
(defun origami-build-tree (buffer parser)
(when parser
(with-current-buffer buffer
(let ((contents (buffer-string)))
(-> parser
(origami-run-parser (origami-content 0 contents))
car
origami-fold-top-level-node)))))
2014-04-14 06:08:02 +10:00
(defun origami-get-parser (buffer is-open data)
2014-04-14 06:08:02 +10:00
;; TODO: remove hardcoding!
(origami-parser-0+ (origami-do
(origami-parser-consume-while (lambda (x)
(not (equal x "{"))))
(origami-parser-paired (origami-parser-char "{")
(origami-parser-char "}")
(origami-do
(origami-parser-consume-while (lambda (x) (and (not (equal x "}"))
(not (equal x "{")))))
(origami-parser-1?
(origami-parser-paired (origami-parser-char "{")
(origami-parser-char "}")
(origami-parser-zero) is-open data)))
is-open data))))
(defun origami-was-previously-open? (tree)
(lambda (beg end)
(-> (origami-fold-find-node-with-range tree beg end)
-last-item
origami-fold-open-p)))
(defun origami-previous-data (tree)
(lambda (beg end)
(-> (origami-fold-find-node-with-range tree beg end)
-last-item
origami-fold-data)))
2014-04-14 06:08:02 +10:00
(defun origami-get-fold-tree (buffer)
"Facade. Build the tree if it hasn't already been built
otherwise fetch cached tree."
;; TODO: caching -- don't parse again if there have been no edits since last time
(origami-build-tree buffer
(origami-get-parser buffer
(origami-was-previously-open?
(origami-get-cached-tree buffer))
(origami-previous-data
(origami-get-cached-tree buffer)))))
2014-04-08 06:50:39 +10:00
;;; dsl
2014-04-14 06:08:02 +10:00
;;; commands
;;; TODO: should ensure that minor mode is enabled?
;;; TODO: extract common pattern
(defun origami-open-node (buffer point)
(interactive (list (current-buffer) (point)))
(let ((tree (origami-get-fold-tree buffer)))
(-when-let (path (origami-fold-find-node-containing tree point))
(debug-msg "open path: %s" path)
(origami-fold-diff tree (origami-store-cached-tree buffer
(origami-fold-open-set path t))
(origami-create-overlay-from-fold-tree-fn buffer)
(origami-delete-overlay-from-fold-tree-fn buffer)
(origami-change-overlay-from-fold-node-fn buffer)))))
(defun origami-close-node (buffer point)
2014-04-14 06:08:02 +10:00
(interactive (list (current-buffer) (point)))
(let ((tree (origami-get-fold-tree buffer)))
(-when-let (path (origami-fold-find-node-containing tree point))
(origami-fold-diff tree (origami-store-cached-tree buffer
(origami-fold-open-set path nil))
(origami-create-overlay-from-fold-tree-fn buffer)
(origami-delete-overlay-from-fold-tree-fn buffer)
(origami-change-overlay-from-fold-node-fn buffer)))))
2014-04-14 06:08:02 +10:00
(defun origami-toggle-node (buffer point))
2014-03-18 06:23:46 +11:00
(defun origami-reset (buffer)
;; TODO: provide this to the user in case we get screwed up, maybe
;; use this when disabling the minor mode?
(interactive)
(origami-remove-all-overlays buffer)
;; TODO: remove fold ds
)
2014-04-14 06:08:02 +10:00
;;; minor mode
2014-03-18 06:23:46 +11:00
;;; origami.el ends here