Improve CRM and journal workflows

1 files changed, 286 insertions, 28 deletions

diff --git a/lisp/ss-crm.el b/lisp/ss-crm.el
index c9b8c16..62dc3e3 100644
--- a/lisp/ss-crm.el
+++ b/lisp/ss-crm.el
@@ -18,6 +18,155 @@
   '("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"
@@ -392,6 +541,93 @@
         (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."
@@ -404,6 +640,50 @@ When INCLUDE-EMPTY is non-nil, keep empty values."
             (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)
@@ -419,35 +699,13 @@ When INCLUDE-EMPTY is non-nil, keep empty values."
         (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)
+          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: "))
-    (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)