diff options
Diffstat (limited to '')
| -rw-r--r-- | emacs.d/custom/fcuny-defuns.el | 225 |
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) |