summaryrefslogtreecommitdiff
path: root/lisp/ss-crm.el
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/ss-crm.el')
-rw-r--r--lisp/ss-crm.el817
1 files changed, 0 insertions, 817 deletions
diff --git a/lisp/ss-crm.el b/lisp/ss-crm.el
deleted file mode 100644
index 62dc3e3..0000000
--- a/lisp/ss-crm.el
+++ /dev/null
@@ -1,817 +0,0 @@
-;;; 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-seeded-roles
- '("Account Manager"
- "AD Platform Manager"
- "AD, Billing & Catalogue, Engineering"
- "AD, Frontend Engineering"
- "AD, IT Core & MarTech"
- "AD, Mobile Engineering"
- "AD, Platform Engineering"
- "AD, Portfolio Delivery Products and API Management"
- "AD, Portfolio Mgmt. Customer Engagement"
- "AD, Quality Engineering"
- "AD, Tech Product Owner"
- "AD, Technical Delivery"
- "AD, Technical Platform Management"
- "AD, Technical Platform Manager, API"
- "AD, Technical Platform Manager, Catalog"
- "AD, Technical Platform Manager, Order and Quote"
- "AD, Technical Product Management"
- "Agile Scrum Master"
- "Analyst Programmer - Senior"
- "Android Developer"
- "Android Developer - Senior"
- "Application Development Lead"
- "Architect"
- "Associate Engineer"
- "Associate Engineer"
- "Associate Engineer, Frontend"
- "Associate Engineer, Platform Engineering"
- "Associate Software Engineer"
- "Billing Executive"
- "Business Analyst"
- "Business Analyst - Senior"
- "Business Development Manager"
- "Business Intelligence Analyst"
- "Business Program Manager"
- "Cloud Engineer"
- "Consultant"
- "CRM Developer"
- "Data Analyst"
- "Data Analyst - Senior"
- "Delivery Lead"
- "Delivery Manager"
- "Demand Lead"
- "Deployment Manager"
- "Development Manager"
- "DevOps Engineer"
- "DevOps Engineer - Senior"
- "Digital Delivery Manager"
- "Director Customer Engagement"
- "Director Sales Technology"
- "Director, Billing and Charging"
- "Director, Delivery Portfolio Billing and Charging"
- "Director, Digital Engineering"
- "Director, Portfolio Mgmt."
- "Director, SF Comms Technical Platform"
- "Director, SSF Core & Commerce"
- "Engineer"
- "Engineer - Junior"
- "Engineer - Senior"
- "Engineer, Platform Engineering"
- "Engineer, Salesforce"
- "Engineering Manager"
- "Engineering Manager, Mobile"
- "Engineering Manager, Platform Engineering"
- "Executive Assistant"
- "Integration Lead"
- "Integration Solution Designer"
- "Integration Technical Specialist"
- "iOS Developer"
- "iOS Developer - Senior"
- "IT Business Partner"
- "Lead Consultant"
- "Lead Developer"
- "Manager, Release Engineer"
- "Manager, Release Train Engineer"
- "Mobile API Developer"
- "Optus Tech Graduate"
- "Portfolio Manager"
- "Process Analyst - Senior"
- "Product Manager"
- "Product Solution Designer"
- "Program Analyst"
- "Program Director"
- "Program Manager"
- "Project Architect"
- "Project Coordinator"
- "Project Manager"
- "Quality Assurance Analyst"
- "Quality Engineering Professional"
- "Release Coordinator"
- "Release Manager"
- "Salesforce Administrator"
- "Salesforce Developer (Heroku, Lightning, etc)"
- "Salesforce Marketing Cloud Architect"
- "Salesforce Operations Manager"
- "Scrum Master"
- "SD, Engineering Capability"
- "SD, Marketing Technology"
- "SD, Technical Products"
- "Senior Business Analyst"
- "Senior Delivery Manager"
- "Senior Delivery Manger"
- "Senior Digital Technical Producer"
- "Senior E2E Business Analyst Lead"
- "Senior Engineer"
- "Senior Engineer, API Engineering"
- "Senior Engineer, Billing & Catalogue"
- "Senior Engineer, Platform Engineering"
- "Senior Engineer, Salesforce"
- "Senior Front End Developer"
- "Senior Integration Solution Designer"
- "Senior Quality Engineering Professional"
- "Senior Salesforce Administrator"
- "Senior Salesforce Consultant"
- "Senior Salesforce Functional Consultant"
- "Senior Salesforce Operations Lead"
- "Senior Software Developer"
- "Senior Software Engineer"
- "Senior Software Engineer, Frontend"
- "Senior Software Engineer, Mobile"
- "Senior Solution Designer"
- "Snr Dir, Delivery & Platform Manager"
- "Snr Director, Portfolio Mgmt. & Delivery"
- "Software Developer"
- "Software Developer - Junior"
- "Software Developer - Senior"
- "Software Engineer"
- "Software Engineer, Frontend"
- "Software Engineer, Mobile"
- "Solution Architect"
- "Solution Designer"
- "Solution Designer - Senior"
- "Staff Engineer"
- "Support Analyst"
- "System Analyst"
- "System Engineer"
- "Technical Lead"
- "Technical Platform Manager"
- "Technical Platform Manager, Billing and Charging"
- "Technical Product Manager"
- "Technical Project Manager - Senior"
- "Technical Specialist - Senior"
- "Technology Delivery Analyst"
- "Test Analyst"
- "Test Lead"
- "Test Manager"
- "VP, EB IT")
- "Seeded role values derived from the historic roles CSV.")
-
-(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-known-property-values (property)
- "Return sorted unique non-empty values for PROPERTY from CRM entries."
- (let ((key (intern (concat ":" (downcase property)))))
- (seq-sort
- #'string<
- (delete-dups
- (seq-filter
- (lambda (value)
- (and (stringp value)
- (not (string-empty-p (string-trim value)))))
- (mapcar
- (lambda (entry)
- (plist-get entry key))
- (ss-crm-entries)))))))
-
-(defun ss-crm-known-person-names ()
- "Return sorted top-level person names from CRM entries."
- (seq-sort
- #'string<
- (delete-dups
- (seq-filter
- (lambda (name)
- (and (stringp name)
- (not (string-empty-p (string-trim name)))))
- (mapcar #'ss-crm--entry-name (ss-crm-entries))))))
-
-(defun ss-crm-lookup-values (property &optional seeded)
- "Return sorted unique values for PROPERTY merged with SEEDED values."
- (seq-sort
- #'string<
- (delete-dups
- (seq-filter
- (lambda (value)
- (and (stringp value)
- (not (string-empty-p (string-trim value)))))
- (append seeded
- (ss-crm-known-property-values property))))))
-
-(defun ss-crm--read-choice-warning (prompt similar)
- "Warn that PROMPT value is similar to existing SIMILAR."
- (display-warning
- 'ss-crm
- (format "%sA similar existing value already exists: %s"
- prompt
- similar)
- :warning))
-
-(defun ss-crm-read-choice (prompt choices &rest plist)
- "Read a value for PROMPT from CHOICES using options in PLIST.
-Supported keywords are :allow-blank, :allow-new, and :require-match."
- (let* ((allow-blank (plist-get plist :allow-blank))
- (allow-new (plist-get plist :allow-new))
- (require-match (plist-get plist :require-match))
- (blank-choice "[none]")
- (collection (if allow-blank
- (cons blank-choice choices)
- choices))
- (completion-require-match (if allow-new nil require-match)))
- (catch 'done
- (while t
- (let* ((value (completing-read prompt collection nil completion-require-match))
- (existing
- (seq-find
- (lambda (choice)
- (string= value choice))
- choices)))
- (cond
- ((or (string-empty-p value)
- (and allow-blank
- (string= value blank-choice)))
- (throw 'done nil))
- (existing
- (throw 'done existing))
- ((not allow-new)
- (user-error "Please choose an existing value"))
- (t
- (when-let ((similar
- (seq-find
- (lambda (choice)
- (and (not (string= value choice))
- (string-equal (downcase value)
- (downcase choice))))
- choices)))
- (ss-crm--read-choice-warning prompt similar))
- (when (yes-or-no-p (format "Create new value `%s'? " value))
- (throw 'done 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-read-role ()
- "Read a CRM role using seeded and known role values."
- (ss-crm-read-choice "Role: "
- (ss-crm-lookup-values "ROLE" ss-crm-seeded-roles)
- :allow-blank t
- :allow-new t))
-
-(defun ss-crm-read-team ()
- "Read a CRM team using known team values."
- (ss-crm-read-choice "Team: "
- (ss-crm-lookup-values "TEAM")
- :allow-blank t
- :allow-new t))
-
-(defun ss-crm-read-manager ()
- "Read a CRM manager using known person names."
- (ss-crm-read-choice "Manager: "
- (ss-crm-known-person-names)
- :allow-blank t
- :require-match t))
-
-(defun ss-crm-read-engagement ()
- "Read a CRM engagement using seeded and known engagement values."
- (ss-crm-read-choice "Engagement: "
- (ss-crm-lookup-values "ENGAGEMENT"
- ss-crm-engagement-options)
- :allow-blank t
- :allow-new t))
-
-(defun ss-crm-read-supplier ()
- "Read a CRM supplier using seeded and known supplier values."
- (ss-crm-read-choice "Supplier: "
- (ss-crm-lookup-values "SUPPLIER"
- ss-crm-supplier-options)
- :allow-blank t
- :allow-new t))
-
-(defun ss-crm-read-location ()
- "Read a CRM location using known location values."
- (ss-crm-read-choice "Location: "
- (ss-crm-lookup-values "LOCATION")
- :allow-blank t
- :allow-new t))
-
-(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 (ss-crm-read-role)
- team (ss-crm-read-team)
- manager (ss-crm-read-manager)
- engagement (ss-crm-read-engagement)
- supplier (ss-crm-read-supplier)
- location (ss-crm-read-location)
- current-focus (ss-crm-read-required-string "Current focus: "))
- (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