path: root/lisp/ss-crm.el

;;; 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