Refactor Emacs config into modules

1 files changed, 559 insertions, 0 deletions

diff --git a/lisp/ss-crm.el b/lisp/ss-crm.el
new file mode 100644
index 0000000..c9b8c16
--- /dev/null
+++ b/lisp/ss-crm.el
@@ -0,0 +1,559 @@
+;;; ss-crm.el --- People CRM -*- lexical-binding: t; -*-
+
+;;; Commentary:
+
+;; People CRM parsing, lookup, completion, insertion, and reporting.
+
+;;; Code:
+
+(require 'abbrev)
+(require 'org)
+(require 'org-element)
+(require 'seq)
+(require 'ss-core)
+(require 'subr-x)
+(require 'marginalia nil t)
+
+(defconst ss-crm-engagement-options
+  '("Perm" "SOW" "SOW Fixed Outcome" "NCS India")
+  "Canonical engagement values for people cards.")
+
+(defconst ss-crm-supplier-options
+  '("Accenture Song"
+    "INFOSYS TECHNOLOGIES LIMITED"
+    "MAKK Integrations Pty Ltd"
+    "NCSI Technologies India Private Limited"
+    "TECH MAHINDRA LTD")
+  "Canonical supplier values for people cards.")
+
+(defvar ss-crm--cache nil
+  "Cached CRM entries loaded from `ss-crm-file'.")
+
+(defvar ss-crm--cache-mtime nil
+  "Modification time of the cached CRM entries.")
+
+(defun ss-crm--entry-name (entry)
+  "Return the canonical name in ENTRY."
+  (plist-get entry :name))
+
+(defun ss-crm--entry-abbrev (entry)
+  "Return the abbrev trigger in ENTRY."
+  (plist-get entry :abbrev))
+
+(defun ss-crm--entry-aliases (entry)
+  "Return alias variants in ENTRY."
+  (plist-get entry :aliases))
+
+(defun ss-crm--entry-role (entry)
+  "Return the role in ENTRY."
+  (plist-get entry :role))
+
+(defun ss-crm--entry-team (entry)
+  "Return the team in ENTRY."
+  (plist-get entry :team))
+
+(defun ss-crm--entry-manager (entry)
+  "Return the manager in ENTRY."
+  (plist-get entry :manager))
+
+(defun ss-crm--entry-engagement (entry)
+  "Return the engagement in ENTRY."
+  (plist-get entry :engagement))
+
+(defun ss-crm--entry-supplier (entry)
+  "Return the supplier in ENTRY."
+  (plist-get entry :supplier))
+
+(defun ss-crm--entry-location (entry)
+  "Return the location in ENTRY."
+  (plist-get entry :location))
+
+(defun ss-crm--entry-current-focus (entry)
+  "Return the current focus in ENTRY."
+  (plist-get entry :current-focus))
+
+(defun ss-crm-default-abbrev (name)
+  "Suggest a short abbrev trigger for NAME."
+  (let* ((parts (split-string (string-trim name) "[[:space:]]+" t))
+         (first (downcase (substring (car parts) 0 (min 2 (length (car parts))))))
+         (last (downcase (substring (car (last parts)) 0 1))))
+    (if (> (length parts) 1)
+        (concat ";" first last)
+      (concat ";" first))))
+
+(defun ss-crm--split-values (value)
+  "Split VALUE on commas and trim each item."
+  (when (and value (not (string-empty-p value)))
+    (seq-filter
+     (lambda (string)
+       (not (string-empty-p string)))
+     (mapcar #'string-trim (split-string value "," t)))))
+
+(defun ss-crm--summary (entry)
+  "Return the compact one-line summary for ENTRY."
+  (string-join
+   (seq-filter
+    (lambda (string)
+      (and string (not (string-empty-p string))))
+    (list (ss-crm--entry-role entry)
+          (ss-crm--entry-team entry)
+          (ss-crm--entry-engagement entry)
+          (ss-crm--entry-current-focus entry)))
+   " | "))
+
+(defun ss-crm--display (entry)
+  "Return the compact display string for ENTRY."
+  (let ((summary (ss-crm--summary entry)))
+    (if (string-empty-p summary)
+        (ss-crm--entry-name entry)
+      (format "%s  %s" (ss-crm--entry-name entry) summary))))
+
+(defun ss-crm--property-line (key value)
+  "Return an Org property line for KEY and VALUE."
+  (if (and value (not (string-empty-p value)))
+      (format ":%s: %s\n" key value)
+    ""))
+
+(defun ss-crm--require-file ()
+  "Return `ss-crm-file', signaling when it is unavailable."
+  (ss-require-existing-file ss-crm-file))
+
+(defun ss-crm--parse-entry-at-point (headline)
+  "Return the CRM entry described by HEADLINE at point."
+  (list :name (org-element-property :raw-value headline)
+        :abbrev (org-entry-get nil "ABBREV")
+        :aliases (ss-crm--split-values (org-entry-get nil "ALIASES"))
+        :role (org-entry-get nil "ROLE")
+        :team (org-entry-get nil "TEAM")
+        :manager (org-entry-get nil "MANAGER")
+        :engagement (org-entry-get nil "ENGAGEMENT")
+        :supplier (org-entry-get nil "SUPPLIER")
+        :location (org-entry-get nil "LOCATION")
+        :current-focus (org-entry-get nil "CURRENT_FOCUS")))
+
+(defun ss-crm--parse-entries ()
+  "Parse top-level CRM entries from `ss-crm-file'."
+  (with-temp-buffer
+    (insert-file-contents (ss-crm--require-file))
+    ;; Parse cards without running user hooks; otherwise the CRM's own Org
+    ;; hooks recurse back into this parser.
+    (delay-mode-hooks
+      (org-mode))
+    (let ((ast (org-element-parse-buffer))
+          cards)
+      (org-element-map ast 'headline
+        (lambda (headline)
+          (when (= 1 (org-element-property :level headline))
+            (goto-char (org-element-property :begin headline))
+            (push (ss-crm--parse-entry-at-point headline) cards))))
+      (sort cards
+            (lambda (left right)
+              (string< (ss-crm--entry-name left)
+                       (ss-crm--entry-name right)))))))
+
+(defun ss-crm-entries ()
+  "Return top-level people cards from `ss-crm-file'."
+  (let* ((file (ss-crm--require-file))
+         (attributes (file-attributes file))
+         (mtime (file-attribute-modification-time attributes)))
+    (unless (and ss-crm--cache
+                 (equal mtime ss-crm--cache-mtime))
+      (setq ss-crm--cache (ss-crm--parse-entries)
+            ss-crm--cache-mtime mtime))
+    ss-crm--cache))
+
+(defun ss-crm-reload ()
+  "Reload the people cache and refresh prose buffers."
+  (interactive)
+  (setq ss-crm--cache nil
+        ss-crm--cache-mtime nil)
+  (ss-crm-refresh-buffers)
+  (message "Reloaded people CRM"))
+
+(defun ss-crm--entry-by-name (name)
+  "Return the people entry matching canonical NAME."
+  (seq-find
+   (lambda (entry)
+     (string= name (ss-crm--entry-name entry)))
+   (ss-crm-entries)))
+
+(defun ss-crm--search-keys (entry)
+  "Return canonical and alias search keys for ENTRY."
+  (cons (ss-crm--entry-name entry)
+        (ss-crm--entry-aliases entry)))
+
+(defun ss-crm--match-p (query entry)
+  "Return non-nil when QUERY matches ENTRY name or aliases."
+  (let* ((parts (split-string (downcase (string-trim query)) "[[:space:]]+" t))
+         (keys (mapcar #'downcase (ss-crm--search-keys entry))))
+    (seq-every-p
+     (lambda (part)
+       (seq-some
+        (lambda (key)
+          (string-match-p (regexp-quote part) key))
+        keys))
+     parts)))
+
+(defun ss-crm--matching-entries (query)
+  "Return entries whose canonical name or aliases match QUERY."
+  (let ((entries (ss-crm-entries)))
+    (if (string-empty-p (string-trim query))
+        entries
+      (seq-filter
+       (lambda (entry)
+         (ss-crm--match-p query entry))
+       entries))))
+
+(defun ss-crm--completion-table (string pred action)
+  "Complete canonical people names while matching aliases via STRING."
+  (if (eq action 'metadata)
+      '(metadata (category . ss-person))
+    (complete-with-action
+     action
+     (mapcar #'ss-crm--entry-name (ss-crm--matching-entries string))
+     string
+     pred)))
+
+(defun ss-crm-marginalia-annotator (candidate)
+  "Return a Marginalia annotation for person CANDIDATE."
+  (when-let ((entry (ss-crm--entry-by-name candidate)))
+    (concat "  " (ss-crm--summary entry))))
+
+(defun ss-crm-select-entry (&optional prompt)
+  "Select a person entry using PROMPT."
+  (let ((completion-extra-properties
+         '(:annotation-function ss-crm-marginalia-annotator)))
+    (ss-crm--entry-by-name
+     (completing-read (or prompt "Person: ")
+                      #'ss-crm--completion-table
+                      nil
+                      t))))
+
+(defun ss-crm-overview ()
+  "Open `ss-crm-file' in overview mode, widening first when needed."
+  (interactive)
+  (unless (and buffer-file-name
+               (string= (file-truename buffer-file-name)
+                        (file-truename ss-crm-file)))
+    (find-file (ss-crm--require-file)))
+  (widen)
+  (goto-char (point-min))
+  (org-overview)
+  (org-cycle-hide-drawers 'all))
+
+(defun ss-crm-open ()
+  "Open the people CRM by delegating to `ss-crm-overview'."
+  (interactive)
+  (ss-crm-overview))
+
+(defun ss-crm--track-buffer ()
+  "Refresh CRM caches when `ss-crm-file' is saved."
+  (when (and buffer-file-name
+             (string= (file-truename buffer-file-name)
+                      (file-truename ss-crm-file)))
+    (add-hook 'after-save-hook #'ss-crm-reload nil t)))
+
+(defun ss-crm--source-buffer-p ()
+  "Return non-nil when the current buffer visits `ss-crm-file'."
+  (and buffer-file-name
+       (string= (file-truename buffer-file-name)
+                (file-truename ss-crm-file))))
+
+(defun ss-crm--open-entry (entry)
+  "Open the people CRM file, then narrow to ENTRY for card view."
+  (find-file (ss-crm--require-file))
+  (widen)
+  (let ((position (org-find-exact-headline-in-buffer
+                   (ss-crm--entry-name entry))))
+    (unless position
+      (user-error "No people card for %s" (ss-crm--entry-name entry)))
+    (goto-char position))
+  (org-narrow-to-subtree)
+  (org-fold-show-subtree)
+  (org-fold-show-entry)
+  (goto-char (point-min)))
+
+(defun ss-crm-find ()
+  "Find a person and open that card."
+  (interactive)
+  (ss-crm--open-entry
+   (or (ss-crm-select-entry "Find person: ")
+       (user-error "No person selected"))))
+
+(defun ss-crm-insert-name ()
+  "Insert a canonical person name at point."
+  (interactive)
+  (let ((entry (or (ss-crm-select-entry "Insert person name: ")
+                   (user-error "No person selected"))))
+    (insert (ss-crm--entry-name entry))))
+
+(defun ss-crm-insert-summary ()
+  "Insert a compact person summary at point."
+  (interactive)
+  (let ((entry (or (ss-crm-select-entry "Insert person summary: ")
+                   (user-error "No person selected"))))
+    (insert (ss-crm--display entry))))
+
+(defun ss-crm--report-buffer (title group-fn)
+  "Render a grouped CRM report titled TITLE using GROUP-FN."
+  (let* ((entries (ss-crm-entries))
+         (groups
+          (seq-group-by
+           (lambda (entry)
+             (let ((value (funcall group-fn entry)))
+               (if (string-empty-p (or value ""))
+                   "(none)"
+                 value)))
+           entries)))
+    (setq groups
+          (sort groups
+                (lambda (left right)
+                  (string< (car left) (car right)))))
+    (with-current-buffer (get-buffer-create "*People Report*")
+      (let ((inhibit-read-only t))
+        (erase-buffer)
+        (org-mode)
+        (insert "#+title: " title "\n\n")
+        (dolist (group groups)
+          (insert "* " (car group) "\n")
+          (dolist (entry (sort (copy-sequence (cdr group))
+                               (lambda (left right)
+                                 (string< (ss-crm--entry-name left)
+                                          (ss-crm--entry-name right)))))
+            (insert "- " (ss-crm--display entry) "\n")))
+        (goto-char (point-min))
+        (read-only-mode 1)
+        (view-mode 1))
+      (pop-to-buffer (current-buffer)))))
+
+(defun ss-crm-report-by-team ()
+  "Show people grouped by team."
+  (interactive)
+  (ss-crm--report-buffer "People by team" #'ss-crm--entry-team))
+
+(defun ss-crm-report-by-manager ()
+  "Show people grouped by manager."
+  (interactive)
+  (ss-crm--report-buffer "People by manager" #'ss-crm--entry-manager))
+
+(defun ss-crm-report-by-engagement ()
+  "Show people grouped by engagement."
+  (interactive)
+  (ss-crm--report-buffer "People by engagement" #'ss-crm--entry-engagement))
+
+(defun ss-crm-report-by-supplier ()
+  "Show non-empty suppliers grouped by supplier."
+  (interactive)
+  (let* ((entries
+          (seq-filter
+           (lambda (entry)
+             (not (string-empty-p (or (ss-crm--entry-supplier entry) ""))))
+           (ss-crm-entries)))
+         (groups (seq-group-by #'ss-crm--entry-supplier entries)))
+    (setq groups
+          (sort groups
+                (lambda (left right)
+                  (string< (car left) (car right)))))
+    (with-current-buffer (get-buffer-create "*People Report*")
+      (let ((inhibit-read-only t))
+        (erase-buffer)
+        (org-mode)
+        (insert "#+title: People by supplier\n\n")
+        (dolist (group groups)
+          (insert "* " (car group) "\n")
+          (dolist (entry (sort (copy-sequence (cdr group))
+                               (lambda (left right)
+                                 (string< (ss-crm--entry-name left)
+                                          (ss-crm--entry-name right)))))
+            (insert "- " (ss-crm--display entry) "\n")))
+        (goto-char (point-min))
+        (read-only-mode 1)
+        (view-mode 1))
+      (pop-to-buffer (current-buffer)))))
+
+(defun ss-crm-report-by-role ()
+  "Show people grouped by role."
+  (interactive)
+  (ss-crm--report-buffer "People by role" #'ss-crm--entry-role))
+
+(defun ss-crm-report-by-location ()
+  "Show people grouped by location."
+  (interactive)
+  (ss-crm--report-buffer "People by location" #'ss-crm--entry-location))
+
+(defun ss-crm-read-string (prompt &optional default)
+  "Read PROMPT and trim the result."
+  (string-trim (read-string prompt nil nil default)))
+
+(defun ss-crm-read-required-string (prompt &optional default)
+  "Read PROMPT and require a non-empty result."
+  (let ((value (ss-crm-read-string prompt default)))
+    (if (string-empty-p value)
+        (user-error "%s is required" (string-remove-suffix ": " prompt))
+      value)))
+
+(defun ss-crm--completion-values (extractor &optional include-empty)
+  "Return sorted unique values using EXTRACTOR.
+When INCLUDE-EMPTY is non-nil, keep empty values."
+  (let ((values (delete-dups (mapcar extractor (ss-crm-entries)))))
+    (seq-sort
+     #'string<
+     (seq-filter
+      (lambda (value)
+        (or include-empty
+            (not (string-empty-p (or value "")))))
+      values))))
+
+(defun ss-crm-add ()
+  "Add a new compact person card to `ss-crm-file'."
+  (interactive)
+  (let ((name (ss-crm-read-required-string "Full name: "))
+        (abbrev nil)
+        (aliases nil)
+        (role nil)
+        (team nil)
+        (manager nil)
+        (engagement nil)
+        (supplier nil)
+        (location nil)
+        (current-focus nil))
+    (setq abbrev (ss-crm-read-string "Abbrev: " (ss-crm-default-abbrev name))
+          aliases (ss-crm-read-string "Aliases (comma-separated, optional): ")
+          role (completing-read "Role: "
+                                (ss-crm--completion-values #'ss-crm--entry-role)
+                                nil nil)
+          team (completing-read "Team: "
+                                (ss-crm--completion-values #'ss-crm--entry-team)
+                                nil nil)
+          manager (completing-read "Manager: "
+                                   (mapcar #'ss-crm--entry-name (ss-crm-entries))
+                                   nil nil)
+          engagement (completing-read "Engagement: "
+                                      ss-crm-engagement-options nil t)
+          supplier (completing-read "Supplier: "
+                                    ss-crm-supplier-options nil t)
+          location (completing-read "Location: "
+                                    (ss-crm--completion-values #'ss-crm--entry-location)
+                                    nil nil)
+          current-focus (ss-crm-read-required-string "Current focus: "))
+    (setq role (if (string-empty-p role)
+                   (ss-crm-read-required-string "Role: ")
+                 role))
+    (setq team (if (string-empty-p team)
+                   (ss-crm-read-required-string "Team: ")
+                 team))
+    (setq manager (if (string-empty-p manager)
+                      (ss-crm-read-required-string "Manager: ")
+                    manager))
+    (setq location (if (string-empty-p location)
+                       (ss-crm-read-required-string "Location: ")
+                     location))
+    (when (ss-crm--entry-by-name name)
+      (user-error "A person card for %s already exists" name))
+    (when (string-empty-p abbrev)
+      (setq abbrev (ss-crm-default-abbrev name)))
+    (find-file (ss-crm--require-file))
+    (widen)
+    (goto-char (point-max))
+    (unless (bolp)
+      (insert "\n"))
+    (unless (looking-back "\n\n" nil)
+      (insert "\n"))
+    (insert "* " name "\n"
+            ":PROPERTIES:\n"
+            (ss-crm--property-line "ABBREV" abbrev)
+            (ss-crm--property-line "ALIASES" aliases)
+            (ss-crm--property-line "ROLE" role)
+            (ss-crm--property-line "TEAM" team)
+            (ss-crm--property-line "MANAGER" manager)
+            (ss-crm--property-line "ENGAGEMENT" engagement)
+            (ss-crm--property-line "SUPPLIER" supplier)
+            (ss-crm--property-line "LOCATION" location)
+            (ss-crm--property-line "CURRENT_FOCUS" current-focus)
+            ":END:\n\n"
+            "** Context\n\n"
+            "** TODOs\n")
+    (save-buffer)
+    (ss-crm-reload)
+    (ss-crm--open-entry (ss-crm--entry-by-name name))))
+
+(defun ss-crm--clear-installed-abbrevs ()
+  "Remove people-specific abbrevs from the current local table."
+  (mapatoms
+   (lambda (symbol)
+     (when (abbrev-get symbol :ss/crm)
+       (define-abbrev local-abbrev-table (symbol-name symbol) nil)))
+   local-abbrev-table))
+
+(defun ss-crm-install-abbrevs ()
+  "Install people abbrevs into the current buffer."
+  (unless (ss-crm--source-buffer-p)
+    (setq-local local-abbrev-table (copy-abbrev-table local-abbrev-table))
+    (ss-crm--clear-installed-abbrevs)
+    (dolist (entry (ss-crm-entries))
+      (let* ((name (ss-crm--entry-name entry))
+             (abbrev (ss-crm--entry-abbrev entry))
+             (abbrev-name
+              (if (or (null abbrev) (string-empty-p abbrev))
+                  (ss-crm-default-abbrev name)
+                abbrev)))
+        (define-abbrev local-abbrev-table abbrev-name name)
+        (when-let ((abbrev-symbol
+                    (abbrev-symbol abbrev-name local-abbrev-table)))
+          (abbrev-put abbrev-symbol :ss/crm t))))))
+
+(defun ss-crm-refresh-buffers ()
+  "Refresh people abbrevs in every prose buffer."
+  (dolist (buffer (buffer-list))
+    (with-current-buffer buffer
+      (when (and (bound-and-true-p abbrev-mode)
+                 (derived-mode-p 'text-mode 'org-mode))
+        (ss-crm-install-abbrevs)))))
+
+(defun ss-crm-capf ()
+  "Return canonical people completions at a word boundary."
+  (let ((end (point)))
+    (save-excursion
+      (skip-syntax-backward "w_")
+      (let ((beg (point)))
+        (when (< beg end)
+          (let ((annotation
+                 (lambda (candidate)
+                   (when-let ((entry (ss-crm--entry-by-name candidate)))
+                     (concat "  " (ss-crm--summary entry)))))
+                (docsig
+                 (lambda (candidate)
+                   (when-let ((entry (ss-crm--entry-by-name candidate)))
+                     (ss-crm--summary entry)))))
+            (list beg end #'ss-crm--completion-table
+                  :exclusive 'no
+                  :annotation-function annotation
+                  :company-docsig docsig)))))))
+
+(defun ss-enable-people-capf ()
+  "Add `ss-crm-capf' once in prose buffers."
+  (unless (or (ss-crm--source-buffer-p)
+              (memq #'ss-crm-capf completion-at-point-functions))
+    (add-hook 'completion-at-point-functions #'ss-crm-capf nil t)))
+
+(defun ss-crm--maybe-overview-buffer ()
+  "Reset the people CRM buffer to overview when visiting it directly."
+  (when (and buffer-file-name
+             (string= (file-truename buffer-file-name)
+                      (file-truename ss-crm-file)))
+    (widen)
+    (goto-char (point-min))
+    (org-overview)
+    (org-cycle-hide-drawers 'all)))
+
+(defun ss-crm-setup ()
+  "Initialize CRM hooks and helpers."
+  (dolist (hook '(text-mode-hook org-mode-hook))
+    (add-hook hook #'ss-enable-people-capf)
+    (add-hook hook #'ss-crm-install-abbrevs))
+  (add-hook 'find-file-hook #'ss-crm--track-buffer)
+  (add-hook 'find-file-hook #'ss-crm--maybe-overview-buffer))
+
+(provide 'ss-crm)
+
+;;; ss-crm.el ends here