hamacs/elisp/org-find-file.el

;;; org-find-file.el --- select org files from title and tags. -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2023 Howard X. Abrams
;;
;; Author: Howard X. Abrams <http://gitlab.com/howardabrams>
;; Maintainer: Howard X. Abrams <howard.abrams@gmail.com>
;; Created: January 8, 2023
;;
;; This file is not part of GNU Emacs.
;;
;; *NB:* Do not edit this file. Instead, edit the original literate file at:
;;            ~/website/Technical/Emacs/org-find-file-tags-2.org
;;       And tangle the file to recreate this one.
;;
;;; Code:

(defun org-find-file (file)
  "Load org-specific file like `find-file'.

If called interactively, the list of files inclues the Org's
title as well as any headline tags."
  (interactive (list (org-find-file--choose-file)))
  (find-file file))

(defun org-find-file--choose-file (&optional directory)
  "Use `completing-read' to present Org files for selection.
Acquires the list of files (and their descriptive text) from
calling `org-find-file--file-choices' (which returns an alist)."
  (let* ((default-directory (if (project-current)
                                (project-root (project-current))
                              (or directory default-directory)))
         (file-choices (org-find-file--file-choices))
         (chosen-file  (completing-read "File: " file-choices)))
    (alist-get chosen-file file-choices nil nil 'equal)))

(defun org-find-file--file-choices ()
  "Return alist of file _labels_ and the file references."
  (let ((titles  (org-find-file--gather-titles))
        (tags    (org-find-file--gather-tags)))
    (seq-map (lambda (entry)
               (seq-let (file title) entry
                 (cons (org-find-file--file-format file title (gethash file tags))
                       file)))
             titles)))

(defun org-find-file--file-format (file title tags)
  "Return a nicely format string containing the parameters."
  (let* ((title-color `(:foreground ,(face-attribute 'org-document-title :foreground)))
         (title-str    (string-trim title))
         (title-pretty (propertize title-str 'face title-color))
         (tag-str      (string-join tags " ")))
    (format "%s : %s %s" file title-pretty tag-str)))

(defun org-find-file--gather-titles ()
  "Return list "
  (thread-last "rg --ignore-case --no-heading --no-line-number '^#\\+title:'"
               (shell-command-to-list)
               (--map (split-string it ":"))
               (--map (list (nth 0 it) (nth 2 it)))))

(defun shell-command-to-list (command)
  "Return call to COMMAND as a list of strings for each line."
  (thread-first command
                shell-command-to-string
                (string-lines t)))

(defvar org-find-files-tag-line-re
  (rx line-start
      (or
       (seq (one-or-more "*") " " (+? any) ":"
            (group (one-or-more (any alnum "@_#%:"))) ":")
       (seq "#+tags:" (one-or-more space)
            (group (one-or-more (any alnum "@_#%" space)))))
      line-end)
  "Regular expression that matches either headline or global file tags.")

(defun org-find-file--gather-tags ()
  "Return hash-table of key as filename, and values are tags.
Note that the tags are _all_ tags in the file."
  (let ((results  (make-hash-table :test 'equal))
        (tag-list (thread-last (format "rg --ignore-case --no-heading --no-line-number '%s'"
                                       (rxt-elisp-to-pcre org-find-files-tag-line-re))
                               (shell-command-to-list)
                               (--map (split-string it ":")))))
    (dolist (entry tag-list)
      (seq-let (file ignored tags) entry
        (let ((prev-tags (gethash file results))
              (new-tags  (org-find-file--massage-tags tags)))
          (puthash file (seq-union prev-tags new-tags) results))))
    results))

(defun org-find-file--massage-tags (tag-string)
  "Return TAG-STRING as a list of tags.
For instance, the string: foo:bar -> '(\"foo\" \"bar\")"
  (let* ((tag-separators (rx (1+ (any space ":"))))
         (tag-list       (split-string tag-string tag-separators t)))
    (--map (concat ":" it) tag-list)))

(provide 'org-find-file)
;;; org-find-file.el ends here