[org] major rewrite of the config

i've used the workflow documented at
http://www.howardism.org/Technical/Emacs/getting-more-boxes-done.html
for the last few days and it's definitely better than anything i've
tried so far.

the rewrite is mostly to replicate the configuration (with some minor
adjustments).

1 files changed, 225 insertions, 0 deletions

diff --git a/emacs.d/custom/fcuny-defuns.el b/emacs.d/custom/fcuny-defuns.el
index 40bd4ce..88e73a3 100644
--- a/emacs.d/custom/fcuny-defuns.el
+++ b/emacs.d/custom/fcuny-defuns.el
@@ -74,4 +74,229 @@
                             (decode-coding-string title 'utf-8))
       (concat "[[" url "][" title "]]"))))
 
+(defun fcuny/org-archive-subtree-as-completed ()
+  "Archives the current subtree to today's current journal entry."
+  (interactive)
+  (ignore-errors
+    ;; According to the docs for `org-archive-subtree', the state should be
+    ;; automatically marked as DONE, but I don't notice that:
+    (when (not (equal "DONE" (org-get-todo-state)))
+      (org-todo "DONE")))
+
+  (let* ((org-archive-file (or org-default-completed-file
+                               (fcuny/this-month-archive-entry)))
+         (org-archive-location (format "%s::" org-archive-file)))
+    (org-archive-subtree)))
+
+(defun fcuny/this-month-archive-entry ()
+  "Return the full pathname to the month's archive entry file.
+Granted, this assumes each journal's file entry to be formatted
+with year/month, as in `201901' for January 4th.
+
+Note: `org-journal-dir' variable must be set to the directory
+where all good journal entries live, e.g. ~/journal."
+  (let* ((daily-name   (format "%s-archive.org" (format-time-string "%Y-%m")))
+         (file-name    (concat org-archive-dir daily-name)))
+    (expand-file-name file-name)))
+
+(defun fcuny/org-subtree-region ()
+  "Return a list of the start and end of a subtree."
+  (save-excursion
+    (list (progn (org-back-to-heading) (point))
+          (progn (org-end-of-subtree)  (point)))))
+
+(defun fcuny/org-refile-directly (file-dest)
+  "Move the current subtree to the end of FILE-DEST.
+If SHOW-AFTER is non-nil, show the destination window,
+otherwise, this destination buffer is not shown."
+  (interactive "fDestination: ")
+
+  (defun dump-it (file contents)
+    (find-file-other-window file-dest)
+    (goto-char (point-max))
+    (insert "\n" contents))
+
+  (save-excursion
+    (let* ((region (fcuny/org-subtree-region))
+           (contents (buffer-substring (first region) (second region))))
+      (apply 'kill-region region)
+      (save-window-excursion (dump-it file-dest contents)))))
+
+(defun fcuny/org-refile-to-task ()
+  "Refile (move) the current Org subtree to `org-default-tasks-file'."
+  (interactive)
+  (fcuny/org-refile-directly org-default-tasks-file))
+
+(defun fcuny/org-refile-to-task ()
+  "Refile (move) the current Org subtree to `org-default-tasks-file'."
+  (interactive)
+  (fcuny/org-refile-directly org-default-tasks-file))
+
+(defun fcuny/org-refile-to-personal-notes ()
+  "Refile (move) the current Org subtree to `org-default-notes-file'."
+  (interactive)
+  (fcuny/org-refile-directly org-default-notes-file))
+
+(defun fcuny/org-refile-subtree-to-file (dir)
+  "Archive the org-mode subtree and create an entry in the
+directory folder specified by DIR. It attempts to move as many of
+the subtree's properties and other features to the new file."
+  (interactive "DDestination: ")
+  (let* ((props      (fcuny/org-subtree-metadata))
+         (head       (plist-get props :header))
+         (body       (plist-get props :body))
+         (tags       (plist-get props :tags))
+         (properties (plist-get props :properties))
+         (area       (plist-get props :region))
+         (filename   (fcuny/org-filename-from-title head))
+         (filepath   (format "%s/%s.org" dir filename)))
+    (apply #'delete-region area)
+    (fcuny/org-create-org-file filepath head body tags properties)))
+
+(defun fcuny/org-set-file-property (key value &optional spot)
+  "Make sure file contains a top-level, file-wide property.
+KEY is something like `TITLE' or `FILETAGS'. This function makes
+sure that the property contains the contents of VALUE, and if the
+file doesn't have the property, it is inserted at either SPOT, or
+if nil,the top of the file."
+  (save-excursion
+    (goto-char (point-min))
+    (let ((case-fold-search t))
+      (if (re-search-forward (format "^#\\+%s:\s*\\(.*\\)" key) nil t)
+          (replace-match value nil nil nil 1)
+
+        (cond
+         ;; if SPOT is a number, go to it:
+         ((numberp spot) (goto-char spot))
+         ;; If SPOT is not given, jump to first blank line:
+         ((null spot) (progn (goto-char (point-min))
+                             (re-search-forward "^\s*$" nil t)))
+         (t (goto-char (point-min))))
+
+        (insert (format "#+%s: %s\n" (upcase key) value))))))
+
+(defun fcuny/org-create-org-file (filepath header body tags properties)
+  "Create a new Org file by FILEPATH. The contents of the file is
+pre-populated with the HEADER, BODY and any associated TAGS."
+  (find-file-other-window filepath)
+  (fcuny/org-set-file-property "TITLE" header t)
+  (when tags
+    (fcuny/org-set-file-property "FILETAGS" (s-join " " tags)))
+
+  ;; Insert any drawer properties as #+PROPERTY entries:
+  (when properties
+    (goto-char (point-min))
+    (or (re-search-forward "^\s*$" nil t) (point-max))
+    (--map (insert (format "#+PROPERTY: %s %s" (first it) (second it))) properties))
+
+  ;; My auto-insert often adds an initial headline for a subtree, and in this
+  ;; case, I don't want that... Yeah, this isn't really globally applicable,
+  ;; but it shouldn't cause a problem for others.
+  (when (re-search-forward "^\\* [0-9]$" nil t)
+    (replace-match ""))
+
+  (delete-blank-lines)
+  (goto-char (point-max))
+  (insert "\n")
+  (insert body))
+
+(defun fcuny/org-subtree-metadata ()
+  "Return a list of key aspects of an org-subtree. Includes the
+following: header text, body contents, list of tags, region list
+of the start and end of the subtree."
+  (save-excursion
+    ;; Jump to the parent header if not already on a header
+    (when (not (org-at-heading-p))
+      (org-previous-visible-heading 1))
+
+    (let* ((context (org-element-context))
+           (attrs   (second context))
+           (props   (org-entry-properties)))
+
+      (list :region     (list (plist-get attrs :begin) (plist-get attrs :end))
+            :header     (plist-get attrs :title)
+            :tags       (fcuny/org-get-subtree-tags props)
+            :properties (fcuny/org-get-subtree-properties attrs)
+            :body       (fcuny/org-get-subtree-content attrs)))))
+
+(defun fcuny/org-filename-from-title (title)
+  "Creates a useful filename based on a header string, TITLE.
+For instance, given the string:    What's all this then?
+     This function will return:    whats-all-this-then"
+  (let* ((no-letters (rx (one-or-more (not alphanumeric))))
+         (init-try (->> title
+                        downcase
+                        (replace-regexp-in-string "'" "")
+                        (replace-regexp-in-string no-letters "-"))))
+    (string-trim init-try "-+" "-+")))
+
+(defun fcuny/org-get-subtree-content (attributes)
+  "Return the contents of the current subtree as a string."
+  (let ((header-components '(clock diary-sexp drawer headline inlinetask
+                             node-property planning property-drawer section)))
+
+      (goto-char (plist-get attributes :contents-begin))
+
+      ;; Walk down past the properties, etc.
+      (while
+          (let* ((cntx (org-element-context))
+                 (elem (first cntx))
+                 (props (second cntx)))
+            (when (member elem header-components)
+              (goto-char (plist-get props :end)))))
+
+      ;; At this point, we are at the beginning of what we consider
+      ;; the contents of the subtree, so we can return part of the buffer:
+      (buffer-substring-no-properties (point) (org-end-of-subtree))))
+
+(defun fcuny/org-get-subtree-properties (attributes)
+  "Return a list of tuples of a subtrees properties where the keys are strings."
+
+  (defun symbol-upcase? (sym)
+    (let ((case-fold-search nil))
+      (string-match-p "^:[A-Z]+$" (symbol-name sym))))
+
+  (defun convert-tuple (tup)
+    (let ((key (first tup))
+          (val (second tup)))
+      (list (substring (symbol-name key) 1) val)))
+
+  (->> attributes
+       (-partition 2)                         ; Convert plist to list of tuples
+       (--filter (symbol-upcase? (first it))) ; Remove lowercase tuples
+       (-map 'convert-tuple)))
+
+(defun fcuny/org-get-subtree-tags (&optional props)
+  "Given the properties, PROPS, from a call to
+`org-entry-properties', return a list of tags."
+  (unless props
+     (setq props (org-entry-properties)))
+  (let ((tag-label "ALLTAGS" ))
+    (-some->> props
+         (assoc tag-label)
+         cdr
+         substring-no-properties
+         (s-split ":")
+         (--filter (not (equalp "" it))))))
+
+(defun fcuny/org-refile-to-projects-dir ()
+  "Move the current subtree to a file in the `projects' directory."
+  (interactive)
+  (fcuny/org-refile-subtree-to-file org-default-projects-dir))
+
+(defun fcuny/org-refile-to-personal-dir ()
+  "Move the current subtree to a file in the `personal' directory."
+  (interactive)
+  (fcuny/org-refile-subtree-to-file org-default-personal-dir))
+
+(defun fcuny/org-refile-to-incubate ()
+  "Refile (move) the current Org subtree to `org-default-incubate-fire'."
+  (interactive)
+  (fcuny/org-refile-directly org-default-incubate-file))
+
+(defun fcuny/org-refile-to-technical-dir ()
+  "Move the current subtree to a file in the `technical' directory."
+  (interactive)
+  (fcuny/org-refile-subtree-to-file org-default-technical-dir))
+
 (provide 'fcuny-defuns)