diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/ss-agenda.el | 40 | ||||
| -rw-r--r-- | lisp/ss-capture.el | 180 | ||||
| -rw-r--r-- | lisp/ss-core.el | 147 | ||||
| -rw-r--r-- | lisp/ss-crm.el | 817 | ||||
| -rw-r--r-- | lisp/ss-denote.el | 49 | ||||
| -rw-r--r-- | lisp/ss-gptel.el | 21 | ||||
| -rw-r--r-- | lisp/ss-keys.el | 60 | ||||
| -rw-r--r-- | lisp/ss-org.el | 306 | ||||
| -rw-r--r-- | lisp/ss-ui.el | 144 |
9 files changed, 0 insertions, 1764 deletions
diff --git a/lisp/ss-agenda.el b/lisp/ss-agenda.el deleted file mode 100644 index a89a52e..0000000 --- a/lisp/ss-agenda.el +++ /dev/null @@ -1,40 +0,0 @@ -;;; ss-agenda.el --- Agenda configuration -*- lexical-binding: t; -*- - -;;; Commentary: - -;; Agenda discovery and agenda commands. - -;;; Code: - -(require 'ss-core) -(require 'ss-org) - -(defun ss-refresh-org-agenda-files (&rest _) - "Refresh `org-agenda-files' from the journal and PARA directories. -Ignore any arguments passed by advice wrappers." - (require 'org-agenda) - (setq org-agenda-files - (sort - (delete-dups - (append - (list (ss-require-existing-file ss-journal-file)) - (apply #'append - (mapcar (lambda (directory) - (directory-files-recursively - (ss-require-existing-directory directory) - "\\.org\\'")) - ss-org-agenda-directories)))) - #'string<))) - -(defun ss-open-agenda () - "Refresh agenda files and invoke `org-agenda'." - (interactive) - (call-interactively #'org-agenda)) - -(defun ss-agenda-setup () - "Initialize agenda behavior." - (advice-add 'org-agenda :before #'ss-refresh-org-agenda-files)) - -(provide 'ss-agenda) - -;;; ss-agenda.el ends here diff --git a/lisp/ss-capture.el b/lisp/ss-capture.el deleted file mode 100644 index 0489888..0000000 --- a/lisp/ss-capture.el +++ /dev/null @@ -1,180 +0,0 @@ -;;; ss-capture.el --- Capture configuration -*- lexical-binding: t; -*- - -;;; Commentary: - -;; Journal capture helpers and capture templates. - -;;; Code: - -(require 'calendar) -(require 'org) -(require 'org-capture) -(require 'ss-core) -(require 'ss-org) - -(defun ss-journal-capture-time () - "Return the effective timestamp for the current journal capture." - (or org-overriding-default-time - (org-capture-get :default-time) - (current-time))) - -(defun ss-journal-calendar-date (&optional time) - "Return TIME as a Gregorian date list for datetree helpers." - (calendar-gregorian-from-absolute - (time-to-days (or time (current-time))))) - -(defun ss-journal-year-heading (&optional time) - "Return the journal year heading text for TIME." - (format-time-string "%Y" (or time (current-time)))) - -(defun ss-journal-day-heading (&optional time) - "Return the journal day heading text for TIME." - (format-time-string "%Y-%m-%d %A" (or time (current-time)))) - -(defun ss-journal-find-or-create-heading (level heading) - "Move to HEADING at LEVEL, creating it when missing." - (goto-char (point-min)) - (if (re-search-forward - (format "^%s %s$" - (make-string level ?*) - (regexp-quote heading)) - nil t) - (goto-char (match-beginning 0)) - (goto-char (point-max)) - (unless (bolp) - (insert "\n")) - (insert (make-string level ?*) " " heading "\n") - (forward-line -1)) - (org-back-to-heading t)) - -(defun ss-journal-goto-date (&optional time create) - "Move to TIME's journal date heading. -When CREATE is non-nil, create the datetree entry when missing." - (goto-char (point-min)) - (if create - (let ((year-heading (ss-journal-year-heading time)) - (day-heading (ss-journal-day-heading time))) - (ss-journal-find-or-create-heading 1 year-heading) - (save-restriction - (org-narrow-to-subtree) - (ss-journal-find-or-create-heading 2 day-heading)) - t) - (when (re-search-forward - (format "^\\*\\* %s$" - (regexp-quote - (ss-journal-day-heading (or time (current-time))))) - nil t) - (goto-char (match-beginning 0)) - t))) - -(defun ss-journal-ensure-day-sections () - "Ensure the standard section headings exist under the current journal day." - (org-back-to-heading t) - (let ((section-level (1+ (org-outline-level)))) - (save-excursion - (save-restriction - (org-narrow-to-subtree) - (dolist (section ss-journal-section-headings) - (goto-char (point-min)) - (forward-line 1) - (unless (re-search-forward - (format "^%s %s$" - (make-string section-level ?*) - (regexp-quote section)) - nil t) - (goto-char (point-max)) - (unless (bolp) - (insert "\n")) - (insert (make-string section-level ?*) " " section "\n"))))))) - -(defun ss-journal-goto-section (section &optional time) - "Move to SECTION beneath TIME's journal date, creating structure as needed." - (unless (member section ss-journal-section-headings) - (user-error "Unknown journal section: %s" section)) - (ss-journal-goto-date time 'create) - (ss-journal-ensure-day-sections) - (let ((section-level (1+ (org-outline-level))) - position) - (save-restriction - (org-narrow-to-subtree) - (goto-char (point-min)) - (when (re-search-forward - (format "^%s %s$" - (make-string section-level ?*) - (regexp-quote section)) - nil t) - (setq position (match-beginning 0)))) - (unless position - (user-error "Journal section not found: %s" section)) - (goto-char position) - (org-back-to-heading t))) - -(defun ss-journal-capture-target (section) - "Select SECTION under today's journal datetree entry for capture." - (set-buffer (find-file-noselect (ss-require-existing-file ss-journal-file))) - (widen) - (ss-journal-goto-section section (ss-journal-capture-time))) - -(defun ss-capture--denote-templates () - "Return Denote-backed capture templates when Denote is enabled." - (when (ss-feature-enabled-p 'denote) - `(("n" "Denote") - ("nn" "Generic" plain - (file denote-last-path) - (function - (lambda () - (denote-org-capture-with-prompts :title :keywords :subdirectory))) - :no-save t - :immediate-finish nil - :kill-buffer t - :jump-to-captured t) - ("np" "Project" plain - (file denote-last-path) - (function - (lambda () - (ss-denote-capture-in-directory - ss-org-projects-directory '("project") :title :keywords :subdirectory))) - :no-save t - :immediate-finish nil - :kill-buffer t - :jump-to-captured t) - ("na" "Area" plain - (file denote-last-path) - (function - (lambda () - (ss-denote-capture-in-directory - ss-org-areas-directory nil :title :keywords :subdirectory))) - :no-save t - :immediate-finish nil - :kill-buffer t - :jump-to-captured t) - ("nr" "Resource" plain - (file denote-last-path) - (function - (lambda () - (ss-denote-capture-in-directory - ss-org-resources-directory nil :title :keywords :subdirectory))) - :no-save t - :immediate-finish nil - :kill-buffer t - :jump-to-captured t)))) - -(defun ss-capture-setup () - "Initialize capture templates." - (setq org-capture-templates - (append - '(("j" "Journal") - ("jt" "Task" entry - (function (lambda () (ss-journal-capture-target "Tasks"))) - "* TODO %?") - ("jn" "Note" entry - (function (lambda () (ss-journal-capture-target "Notes"))) - "* %?") - ("jm" "Meeting" entry - (function (lambda () (ss-journal-capture-target "Meetings"))) - "* <%<%Y-%m-%d %H:%M>> %?")) - (ss-capture--denote-templates)))) - -(provide 'ss-capture) - -;;; ss-capture.el ends here diff --git a/lisp/ss-core.el b/lisp/ss-core.el deleted file mode 100644 index 3be0711..0000000 --- a/lisp/ss-core.el +++ /dev/null @@ -1,147 +0,0 @@ -;;; ss-core.el --- Shared core setup -*- lexical-binding: t; -*- - -;;; Commentary: - -;; Shared startup helpers, package bootstrap, paths, and editor defaults. - -;;; Code: - -(require 'subr-x) - -(defconst ss-minimum-emacs-version "27.1" - "Minimum supported Emacs version.") - -(defconst ss-warning-emacs-version "28.1" - "Version threshold for compatibility warnings.") - -(defconst ss-spell-check-support-enabled nil) -(defconst ss-is-windows (memq system-type '(windows-nt ms-dos cygwin))) -(defconst ss-is-linux (eq system-type 'gnu/linux)) -(defconst ss-is-mac (eq system-type 'darwin)) - -(defconst ss-org-directory (expand-file-name "~/org/") - "Root directory for Org files.") - -(defconst ss-journal-file (expand-file-name "journal.org" ss-org-directory) - "Single-file work journal for operational capture.") - -(defconst ss-org-projects-directory (expand-file-name "projects/" ss-org-directory) - "Directory for project notes.") - -(defconst ss-org-areas-directory (expand-file-name "areas/" ss-org-directory) - "Directory for area notes.") - -(defconst ss-org-resources-directory (expand-file-name "resources/" ss-org-directory) - "Directory for resource notes.") - -(defconst ss-org-archives-directory (expand-file-name "archives/" ss-org-directory) - "Directory for archived notes.") - -(defconst ss-moc-file (expand-file-name "moc.org" ss-org-directory) - "Central MOC note.") - -(defconst ss-crm-file (expand-file-name "areas/people/people.org" ss-org-directory) - "Single source of truth for the people CRM.") - -(defconst ss-journal-section-headings - '("Tasks" "Notes" "Meetings") - "Per-day section headings maintained under each journal datetree entry.") - -(defconst ss-org-agenda-directories - (list ss-org-projects-directory - ss-org-areas-directory - ss-org-resources-directory) - "Directories whose Org files feed the agenda.") - -(defun ss-feature-enabled-p (feature) - "Return non-nil when FEATURE is enabled in `ss-enabled-features'." - (memq feature ss-enabled-features)) - -(defun ss-require-existing-directory (directory) - "Return DIRECTORY, signaling when it does not exist." - (unless (file-directory-p directory) - (user-error "Directory does not exist: %s" directory)) - directory) - -(defun ss-require-existing-file (file) - "Return FILE, signaling when it does not exist." - (unless (file-exists-p file) - (user-error "File does not exist: %s" file)) - file) - -(defun ss-enable-prose-abbrev-mode () - "Enable abbrev mode in prose buffers. -We keep this mode-local so code buffers stay on their own completion rules." - (abbrev-mode 1)) - -(defun ss-core-setup () - "Initialize shared core behavior." - (let ((minver ss-minimum-emacs-version)) - (when (version< emacs-version minver) - (error "Your Emacs is too old -- this config requires v%s or higher" minver))) - (when (version< emacs-version ss-warning-emacs-version) - (message - (concat - "Your Emacs is old, and some functionality in this config will be " - "disabled. Please upgrade if possible."))) - - ;; Keep custom-set-variables out of the main config. - (setq custom-file (expand-file-name "custom.el" user-emacs-directory)) - - (require 'package) - (setq package-archives - (append '(("melpa" . "https://melpa.org/packages/")) - package-archives) - package-archive-priorities '(("gnu" . 10) - ("nongnu" . 8) - ("melpa" . 5)) - package-install-upgrade-built-in t - use-package-always-ensure nil) - (package-initialize) - (require 'use-package) - (require 'abbrev) - - (set-language-environment "UTF-8") - (set-default-coding-systems 'utf-8) - (prefer-coding-system 'utf-8) - - (setq abbrev-file-name (expand-file-name "abbrev_defs" user-emacs-directory) - save-abbrevs 'silently) - (when (file-exists-p abbrev-file-name) - (quietly-read-abbrev-file abbrev-file-name)) - - (dolist (hook '(text-mode-hook org-mode-hook)) - (add-hook hook #'ss-enable-prose-abbrev-mode)) - - (setq auto-save-default nil - backup-inhibited t - echo-keystrokes 0.1 - compilation-ask-about-save nil - mouse-wheel-scroll-amount '(1 ((shift) . 1)) - mouse-wheel-progressive-speed nil - mouse-wheel-follow-mouse t - scroll-step 1 - scroll-conservatively 101 - enable-recursive-minibuffers t - gc-cons-threshold (* 128 1024 1024) - read-process-output-max (* 4 1024 1024) - process-adaptive-read-buffering nil) - - (fset 'yes-or-no-p 'y-or-n-p) - (global-auto-revert-mode 1) - (delete-selection-mode 1) - - (setq-default indent-tabs-mode nil - fill-column 80 - tab-width 2 - indicate-empty-lines t - sentence-end-double-space nil)) - -(defun ss-core-load-custom-file () - "Load `custom-file' when it exists." - (when (file-exists-p custom-file) - (load custom-file nil 'nomessage))) - -(provide 'ss-core) - -;;; ss-core.el ends here 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 diff --git a/lisp/ss-denote.el b/lisp/ss-denote.el deleted file mode 100644 index 65b9b53..0000000 --- a/lisp/ss-denote.el +++ /dev/null @@ -1,49 +0,0 @@ -;;; ss-denote.el --- Denote configuration -*- lexical-binding: t; -*- - -;;; Commentary: - -;; Durable note creation and Denote integration. - -;;; Code: - -(require 'ss-core) - -(declare-function denote-keywords-prompt "denote") -(declare-function denote-org-capture "denote") -(declare-function denote-org-capture-with-prompts "denote") - -(defun ss-denote-capture-in-directory (directory &optional keywords &rest prompts) - "Start a Denote Org capture in DIRECTORY with KEYWORDS and PROMPTS. -If PROMPTS is empty, rely on `denote-prompts'." - (let* ((prompt-for-keywords (memq :keywords prompts)) - (directory (ss-require-existing-directory directory)) - (denote-directory directory) - (denote-use-directory (unless (memq :subdirectory prompts) directory)) - (denote-use-keywords - (if prompt-for-keywords - (delete-dups (append keywords (denote-keywords-prompt))) - keywords))) - (if prompts - (denote-org-capture-with-prompts - (memq :title prompts) - nil - (memq :subdirectory prompts) - (memq :date prompts) - (memq :template prompts)) - (denote-org-capture)))) - -(defun ss-denote-setup () - "Initialize Denote." - (use-package denote - :ensure t - :after org - :config - (setq denote-directory ss-org-directory - denote-known-keywords '("project") - denote-prompts '(title keywords) - denote-org-capture-specifiers "%?") - (denote-rename-buffer-mode 1))) - -(provide 'ss-denote) - -;;; ss-denote.el ends here diff --git a/lisp/ss-gptel.el b/lisp/ss-gptel.el deleted file mode 100644 index bef5ce7..0000000 --- a/lisp/ss-gptel.el +++ /dev/null @@ -1,21 +0,0 @@ -;;; ss-gptel.el --- GPTel integration -*- lexical-binding: t; -*- - -;;; Commentary: - -;; Experimental gptel setup using the GitHub Copilot backend. - -;;; Code: - -(require 'ss-core) - -(defun ss-gptel-setup () - "Initialize gptel." - (if (require 'gptel nil t) - (setq gptel-default-mode 'org-mode - gptel-model 'gpt-4o - gptel-backend (gptel-make-gh-copilot "Copilot")) - (message "Skipping gptel setup because the package is unavailable."))) - -(provide 'ss-gptel) - -;;; ss-gptel.el ends here diff --git a/lisp/ss-keys.el b/lisp/ss-keys.el deleted file mode 100644 index 4816eea..0000000 --- a/lisp/ss-keys.el +++ /dev/null @@ -1,60 +0,0 @@ -;;; ss-keys.el --- Global keybindings -*- lexical-binding: t; -*- - -;;; Commentary: - -;; Centralized global keybindings for enabled features. - -;;; Code: - -(require 'ss-core) - -(defun ss-keys-setup () - "Install global keybindings for enabled features." - (when (ss-feature-enabled-p 'agenda) - (global-set-key (kbd "C-c a") #'ss-open-agenda)) - - (when (ss-feature-enabled-p 'capture) - (global-set-key (kbd "C-c c") #'org-capture)) - - (when (ss-feature-enabled-p 'org) - (global-set-key (kbd "C-c b") #'ss-jump-back) - (global-set-key (kbd "C-c f") #'ss-jump-forward)) - - (when (and (ss-feature-enabled-p 'denote) - (fboundp 'denote-open-or-create) - (fboundp 'denote-link)) - (global-set-key (kbd "C-c n n") #'denote-open-or-create) - (global-set-key (kbd "C-c n l") #'denote-link)) - - (when (ss-feature-enabled-p 'org) - (global-set-key (kbd "C-c n M") #'ss-open-moc) - (global-set-key (kbd "C-c n j") #'ss-open-journal-full) - (global-set-key (kbd "C-c n d") #'ss-open-journal)) - - (when (ss-feature-enabled-p 'crm) - (global-set-key (kbd "C-c n E") #'ss-crm-report-by-engagement) - (global-set-key (kbd "C-c n f") #'ss-crm-find) - (global-set-key (kbd "C-c n i") #'ss-crm-insert-name) - (global-set-key (kbd "C-c n I") #'ss-crm-insert-summary) - (global-set-key (kbd "C-c n L") #'ss-crm-report-by-location) - (global-set-key (kbd "C-c n o") #'ss-crm-overview) - (global-set-key (kbd "C-c n O") #'ss-crm-report-by-role) - (global-set-key (kbd "C-c n p") #'ss-crm-open) - (global-set-key (kbd "C-c n P") #'ss-crm-add) - (global-set-key (kbd "C-c n R") #'ss-crm-report-by-manager) - (global-set-key (kbd "C-c n S") #'ss-crm-report-by-supplier) - (global-set-key (kbd "C-c n T") #'ss-crm-report-by-team)) - - (when (and (ss-feature-enabled-p 'gptel) - (fboundp 'gptel) - (fboundp 'gptel-send) - (fboundp 'gptel-rewrite) - (fboundp 'gptel-add)) - (global-set-key (kbd "C-c n g") #'gptel) - (global-set-key (kbd "C-c n s") #'gptel-send) - (global-set-key (kbd "C-c n r") #'gptel-rewrite) - (global-set-key (kbd "C-c n a") #'gptel-add))) - -(provide 'ss-keys) - -;;; ss-keys.el ends here diff --git a/lisp/ss-org.el b/lisp/ss-org.el deleted file mode 100644 index fc8fc9b..0000000 --- a/lisp/ss-org.el +++ /dev/null @@ -1,306 +0,0 @@ -;;; ss-org.el --- Base Org configuration -*- lexical-binding: t; -*- - -;;; Commentary: - -;; Shared Org setup and note-opening helpers. - -;;; Code: - -(require 'org) -(require 'ss-core) - -(defvar ss-navigation-back-stack nil - "Stack of older locations for `ss-jump-back'.") - -(defvar ss-navigation-forward-stack nil - "Stack of newer locations for `ss-jump-forward'.") - -(defvar ss-navigation--inhibit-recording nil - "When non-nil, suppress navigation history recording.") - -(defun ss-navigation--current-location () - "Return the current location as a marker-backed plist." - (unless (minibufferp (current-buffer)) - (list :marker (copy-marker (point-marker)) - :window-start - (when (window-live-p (selected-window)) - (copy-marker (window-start (selected-window))))))) - -(defun ss-navigation--location-valid-p (location) - "Return non-nil when LOCATION still points to a live buffer position." - (when-let ((marker (plist-get location :marker))) - (and (markerp marker) - (marker-buffer marker) - (marker-position marker)))) - -(defun ss-navigation--same-location-p (left right) - "Return non-nil when LEFT and RIGHT identify the same buffer position." - (and (ss-navigation--location-valid-p left) - (ss-navigation--location-valid-p right) - (eq (marker-buffer (plist-get left :marker)) - (marker-buffer (plist-get right :marker))) - (= (marker-position (plist-get left :marker)) - (marker-position (plist-get right :marker))))) - -(defun ss-navigation--prune-stack (stack) - "Return STACK with dead or duplicate locations removed." - (let (pruned previous) - (dolist (location stack (nreverse pruned)) - (when (and (ss-navigation--location-valid-p location) - (not (ss-navigation--same-location-p location previous))) - (push location pruned) - (setq previous location))))) - -(defun ss-navigation--push-location (stack-symbol location &optional clear-forward) - "Push LOCATION onto STACK-SYMBOL unless it duplicates the top entry. -When CLEAR-FORWARD is non-nil, reset `ss-navigation-forward-stack'." - (when (ss-navigation--location-valid-p location) - (set stack-symbol (ss-navigation--prune-stack (symbol-value stack-symbol))) - (unless (ss-navigation--same-location-p location (car (symbol-value stack-symbol))) - (set stack-symbol (cons location (symbol-value stack-symbol)))) - (when clear-forward - (setq ss-navigation-forward-stack nil)) - t)) - -(defun ss-navigation-push-current-location () - "Push the current location onto the back stack. -This is for significant navigation points only and clears forward history." - (interactive) - (ss-navigation--push-location - 'ss-navigation-back-stack - (ss-navigation--current-location) - 'clear-forward)) - -(defun ss-navigation--restore-location (location) - "Restore LOCATION, returning non-nil when successful." - (when (ss-navigation--location-valid-p location) - (let* ((marker (plist-get location :marker)) - (buffer (marker-buffer marker)) - (window-start (plist-get location :window-start))) - (switch-to-buffer buffer) - (goto-char marker) - (when (and (markerp window-start) - (eq (marker-buffer window-start) buffer) - (window-live-p (selected-window))) - (set-window-start (selected-window) - (marker-position window-start) - t)) - t))) - -(defun ss-navigation--jump-from-stack (stack-symbol target-symbol) - "Restore the next location from STACK-SYMBOL and push current onto TARGET-SYMBOL." - (set stack-symbol (ss-navigation--prune-stack (symbol-value stack-symbol))) - (when-let ((target (car (symbol-value stack-symbol)))) - (let ((current (ss-navigation--current-location))) - (set stack-symbol (cdr (symbol-value stack-symbol))) - (when (ss-navigation--location-valid-p current) - (ss-navigation--push-location target-symbol current)) - (let ((ss-navigation--inhibit-recording t)) - (ss-navigation--restore-location target))))) - -(defun ss-navigation--jump-via-command (command) - "Use COMMAND as a mark-ring fallback jump, recording forward history." - (when (fboundp command) - (let ((before (ss-navigation--current-location)) - after) - (let ((ss-navigation--inhibit-recording t)) - (condition-case nil - (call-interactively command) - (error nil))) - (setq after (ss-navigation--current-location)) - (when (and (ss-navigation--location-valid-p before) - (ss-navigation--location-valid-p after) - (not (ss-navigation--same-location-p before after))) - (ss-navigation--push-location 'ss-navigation-forward-stack before) - t)))) - -(defun ss-jump-back () - "Move backward through navigation history." - (interactive) - (or (ss-navigation--jump-from-stack - 'ss-navigation-back-stack - 'ss-navigation-forward-stack) - (ss-navigation--jump-via-command 'pop-global-mark) - (ss-navigation--jump-via-command 'pop-to-mark-command) - (progn - (message "No back location available") - nil))) - -(defun ss-jump-forward () - "Move forward through navigation history." - (interactive) - (or (ss-navigation--jump-from-stack - 'ss-navigation-forward-stack - 'ss-navigation-back-stack) - (progn - (message "No forward location available") - nil))) - -(defun ss-navigation--record-jump (original &rest args) - "Record the pre-jump location around ORIGINAL with ARGS." - (if ss-navigation--inhibit-recording - (apply original args) - (let ((before (ss-navigation--current-location)) - result) - (setq result (apply original args)) - (let ((after (ss-navigation--current-location))) - (when (and (ss-navigation--location-valid-p before) - (ss-navigation--location-valid-p after) - (not (ss-navigation--same-location-p before after))) - (ss-navigation--push-location - 'ss-navigation-back-stack - before - 'clear-forward))) - result))) - -(defun ss-navigation--advise-command (command) - "Wrap COMMAND so significant jumps record navigation history." - (unless (advice-member-p #'ss-navigation--record-jump command) - (advice-add command :around #'ss-navigation--record-jump))) - -(defun ss-navigation-setup () - "Install navigation history advice for note-related jump commands." - (dolist (command '(ss-open-journal - ss-open-journal-today-session - ss-open-journal-full - ss-open-moc)) - (ss-navigation--advise-command command)) - (with-eval-after-load 'org - (ss-navigation--advise-command 'org-open-at-point)) - (with-eval-after-load 'org-agenda - (dolist (command '(org-agenda-goto - org-agenda-switch-to - org-agenda-open-link)) - (ss-navigation--advise-command command))) - (with-eval-after-load 'denote - (ss-navigation--advise-command 'denote-open-or-create)) - (with-eval-after-load 'ss-crm - (dolist (command '(ss-crm-find - ss-crm-open - ss-crm-overview)) - (ss-navigation--advise-command command)))) - -(defvar ss-journal-session-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c C-c") #'ss-journal-session-save-and-dismiss) - (define-key map (kbd "C-c C-k") #'ss-journal-session-dismiss) - map) - "Keymap for focused journal editing sessions.") - -(defconst ss-journal-session-header-line - "Journal session: C-c C-c save and dismiss, C-c C-k dismiss" - "Header line shown during focused journal editing sessions.") - -(define-minor-mode ss-journal-session-mode - "Minor mode for focused journal editing sessions." - :lighter " Journal-Session" - :keymap ss-journal-session-mode-map - (if ss-journal-session-mode - (setq-local header-line-format ss-journal-session-header-line) - (kill-local-variable 'header-line-format))) - -(defun ss-journal-session-dismiss () - "End the focused journal session without saving automatically." - (interactive) - (widen) - (ss-journal-session-mode -1) - (quit-window nil (selected-window))) - -(defun ss-journal-session-save-and-dismiss () - "Save the journal buffer, then end the focused journal session." - (interactive) - (save-buffer) - (ss-journal-session-dismiss)) - -(defun ss-open-journal () - "Open today's journal entry in a focused session, creating it when needed." - (interactive) - (ss-open-journal-today-session)) - -(defun ss-open-journal-today-session () - "Open today's journal entry in a focused, dismissable session." - (interactive) - (find-file (ss-require-existing-file ss-journal-file)) - (widen) - (unless (fboundp 'ss-journal-goto-date) - (user-error "Journal date navigation is unavailable")) - (ss-journal-goto-date nil 'create) - (when (fboundp 'ss-journal-ensure-day-sections) - (ss-journal-ensure-day-sections)) - (org-fold-show-entry) - (org-fold-show-subtree) - (org-narrow-to-subtree) - (ss-journal-session-mode 1)) - -(defun ss-open-journal-full () - "Open `ss-journal-file' with the full buffer visible." - (interactive) - (find-file (ss-require-existing-file ss-journal-file)) - (widen)) - -(defun ss-open-moc () - "Open the central MOC note." - (interactive) - (find-file (ss-require-existing-file ss-moc-file))) - -(defun ss-org-refresh-agenda-files-for-refile (&rest _args) - "Refresh `org-agenda-files' before refile when agenda setup is available." - (when (fboundp 'ss-refresh-org-agenda-files) - (ss-refresh-org-agenda-files))) - -(defun ss-org-configure-refile () - "Configure Org refile to target any heading in `org-agenda-files'." - (setq org-refile-targets '((org-agenda-files :regexp . "^\\*+ ")) - org-refile-use-outline-path 'file - org-outline-path-complete-in-steps nil) - (unless (advice-member-p #'ss-org-refresh-agenda-files-for-refile #'org-refile) - (advice-add 'org-refile :before #'ss-org-refresh-agenda-files-for-refile))) - -(defun ss-org-setup () - "Initialize base Org configuration." - (use-package org - :ensure nil - :config - (setq org-directory ss-org-directory - org-catch-invisible-edits 'error - org-hide-emphasis-markers t - org-agenda-search-headline-for-time t - org-agenda-custom-commands - '( - ("d" "Daily Agenda" - ((agenda "") - (todo "CLARIFY" - ((org-agenda-overriding-header "Open Questions")))))) - org-todo-keywords - '((sequence "TODO(t)" "CLARIFY(c)" "WAIT(w@/!)" "|" - "DONE(d)" "CANCELLED(x@)")) - org-log-done 'note - org-log-into-drawer t) - (ss-org-configure-refile) - (add-hook 'org-mode-hook - (lambda () - (setq-local org-hide-emphasis-markers t) - (when (fboundp 'olivetti-mode) - (olivetti-mode 1)) - (font-lock-flush) - (font-lock-ensure)))) - - (use-package git-auto-commit-mode - :ensure t - :pin melpa - :commands (git-auto-commit-mode) - :init - (setq gac-shell-and - (if (string-match-p "fish\\'" shell-file-name) - " ; and " - " && "))) - - (add-hook 'emacs-startup-hook - (lambda () - (find-file (ss-require-existing-file ss-moc-file)))) - - (ss-navigation-setup)) - -(provide 'ss-org) - -;;; ss-org.el ends here diff --git a/lisp/ss-ui.el b/lisp/ss-ui.el deleted file mode 100644 index 3dd728c..0000000 --- a/lisp/ss-ui.el +++ /dev/null @@ -1,144 +0,0 @@ -;;; ss-ui.el --- Interface configuration -*- lexical-binding: t; -*- - -;;; Commentary: - -;; Theme, frame, completion, and interface setup. - -;;; Code: - -(require 'ss-core) - -(defun ss-ui--configure-frames () - "Apply GUI and terminal frame behavior." - (when (display-graphic-p) - (set-frame-size (selected-frame) 140 42) - (menu-bar-mode -1) - (tool-bar-mode -1) - (scroll-bar-mode -1) - (tooltip-mode -1) - (set-face-attribute - 'default nil - :family "JetBrains Mono" :height 140 :weight 'medium) - (set-face-attribute - 'fixed-pitch nil - :family "JetBrains Mono" :weight 'medium) - (set-face-attribute - 'fixed-pitch-serif nil - :family "JetBrains Mono" :weight 'medium)) - - (unless (display-graphic-p) - ;; Terminal menu bar removal stays on startup hook to avoid tty regressions. - (add-hook 'emacs-startup-hook (lambda () (menu-bar-mode -1))))) - -(defun ss-ui--setup-modeline () - "Configure the modeline." - (use-package time - :ensure nil - :config - (setq display-time-24hr-format t - display-time-day-and-date t - display-time-default-load-average nil - calendar-latitude -37.7667 - calendar-longitude 145.0 - calendar-location-name "Melbourne, VIC") - (display-time-mode 1)) - - ;; Keep the theme's faces, but make the right edge alignment dynamic. - (setq-default mode-line-format - (list - " " - "%e" - mode-line-front-space - mode-line-mule-info - mode-line-client - mode-line-modified - mode-line-remote - mode-line-frame-identification - mode-line-buffer-identification - " " - mode-line-position - '(vc-mode vc-mode) - " " - mode-line-modes - '(:eval (propertize - " " - 'display - `((space :align-to - (- right - ,(+ 2 (string-width - (format-mode-line mode-line-misc-info)))))))) - mode-line-misc-info - " " - mode-line-end-spaces))) - -(defun ss-ui--setup-completion () - "Configure minibuffer and in-buffer completion." - (use-package vertico - :ensure t - :pin melpa - :init - (vertico-mode 1)) - - (use-package orderless - :ensure t - :pin melpa - :custom - (completion-styles '(orderless basic)) - (completion-category-defaults nil) - (completion-category-overrides '((file (styles basic partial-completion))))) - - (use-package marginalia - :ensure t - :pin melpa - :after vertico - :init - (marginalia-mode 1)) - - (use-package corfu - :ensure t - :pin gnu - :init - (global-corfu-mode 1))) - -(defun ss-ui--setup-writing-layout () - "Configure centered writing layout helpers." - (use-package olivetti - :ensure t - :pin melpa - :custom - (olivetti-body-width 100))) - -(defun ss-ui-setup () - "Initialize interface and completion behavior." - (setq inhibit-startup-message t - inhibit-startup-screen t - ring-bell-function 'ignore) - - (ss-ui--configure-frames) - - (use-package modus-themes - :ensure nil - :no-require t - :config - (load-theme 'modus-vivendi t)) - - (use-package dired - :ensure nil - :custom - (dired-use-ls-dired nil)) - - (line-number-mode 1) - (column-number-mode 1) - (show-paren-mode 1) - - (setq-default indicate-empty-lines nil) - (setq-default indicate-buffer-boundaries nil) - (setq-default fringe-indicator-alist nil) - - (ss-ui--setup-modeline) - (ss-ui--setup-completion) - (ss-ui--setup-writing-layout)) - -(provide 'ss-ui) - -;;; ss-ui.el ends here |