From 83d0b77f934416ab0957473cec2e4dd0ebeeee02 Mon Sep 17 00:00:00 2001 From: cashmere Date: Fri, 21 Aug 2026 01:12:59 +0200 Subject: md: 2026-08-21T01:12:59+02:00 --- config.el | 100 +++- config.org | 110 +++- custom-vars.el | 8 +- lisp/fossil-ui.el | 1283 +++++++++++++++++++++++++++++++++++++++++++++++ lisp/himalaya-client.el | 461 +++++++++++++++++ lisp/himalaya-ui.el | 1128 +++++++++++++++++++++++++++++++++++++++++ lisp/my-mode-line.el | 145 ++++-- test/fossil-ui-test.el | 248 +++++++++ 8 files changed, 3422 insertions(+), 61 deletions(-) create mode 100644 lisp/fossil-ui.el create mode 100644 lisp/himalaya-client.el create mode 100644 lisp/himalaya-ui.el create mode 100644 test/fossil-ui-test.el diff --git a/config.el b/config.el index 215c2f2..ce74f94 100644 --- a/config.el +++ b/config.el @@ -2,7 +2,7 @@ (setq pgtk-wait-for-event-timeout 0.001) (setq package-enable-at-startup nil) ;; (setq-default mode-line-format t) ;; disabled: boolean t is not valid for mode-line-format -(setq default-frame-alist '((undecorated . t))) +(add-to-list 'default-frame-alist '(undecorated . t)) ;; GC + file-name-handler-alist tuning lives in early-init.el now. (setq create-lockfiles nil) (setq make-backup-files nil) @@ -22,8 +22,30 @@ (defvar my/local-packages nil "Alist of (PACKAGE . DIRECTORY) loaded from a local checkout. Set per-host in the gitignored `local.el'.") + (defvar cashmere/frame-alpha-background nil + "Per-host frame opacity, or nil for the Emacs default.") + (defvar cashmere/font-height 180 + "Per-host default font height in tenths of a point.") + (defvar cashmere/theme nil + "Per-host theme to load, or nil for no theme.") (load (locate-user-emacs-file "local.el") 'noerror 'nomessage)) +;; Apply appearance settings at runtime only. Keeping these outside +;; `eval-and-compile' avoids loading themes or mutating the initial daemon +;; frame while native compilation is inspecting the configuration. +(when cashmere/frame-alpha-background + (add-to-list 'default-frame-alist + `(alpha-background . ,cashmere/frame-alpha-background)) + (when (display-graphic-p) + (set-frame-parameter nil 'alpha-background + cashmere/frame-alpha-background))) + +(when cashmere/theme + (add-to-list 'custom-theme-load-path + (expand-file-name "themes" user-emacs-directory)) + (unless (memq cashmere/theme custom-enabled-themes) + (load-theme cashmere/theme t))) + (dolist (entry my/local-packages) (add-to-list 'load-path (expand-file-name (cdr entry)))) @@ -411,16 +433,16 @@ Selects the compilation window so the cursor lands in it." (defun my/erc-fetch-history (&optional count) "Fetch COUNT previous messages from Soju via CHATHISTORY. -Defaults to 1000 (soju max). With prefix arg, prompts for count. +Defaults to 100 (soju max). With prefix arg, prompts for count. Temporarily disables notifications during the fetch." (interactive "P") (let ((target (erc-default-target))) (if (not target) (message "Not in a channel buffer.") (let ((n (min (if count - (read-number "Messages to fetch: " 1000) - 1000) - 1000))) + (read-number "Messages to fetch: " 100) + 100) + 100))) (erc-notifications-disable) (erc-server-send (format "CHATHISTORY LATEST %s * %d" target n)) (run-at-time 5 nil #'erc-notifications-enable))))) @@ -597,6 +619,11 @@ Temporarily disables notifications during the fetch." (240 . "#74c7ec") (260 . "#89b4fa") (280 . "#b4befe")))) +(use-package vc-fossil + ;; Keep from loading unnecessarily at startup. + :ensure t + ;; This allows VC to load vc-fossil when needed. + :init (add-to-list 'vc-handled-backends 'Fossil t)) (use-package ibuffer :ensure nil @@ -2395,13 +2422,17 @@ Timers that expired while Emacs was closed fire immediately." :mode "\\.typ\\'") (use-package yasnippet - :ensure t + :ensure (:wait t) + :demand t :config (yas-global-mode 1)) (use-package yasnippet-snippets - :ensure t - :after yasnippet) + :ensure (:wait t) + :demand t + :after yasnippet + :config + (yas-reload-all)) (use-package nix-ts-mode :ensure t @@ -2886,6 +2917,13 @@ created later still get them." (set-face-attribute 'fixed-pitch frame :family "Maple Mono NF" :weight 'regular) (set-face-attribute 'variable-pitch frame :family "Maple Mono NF" :weight 'regular :height 1.1))) +;; A daemon's first GUI frame must be born with the final font. Applying it +;; only from `server-after-make-frame-hook' lets the compositor show one frame +;; with the fallback font first, which changes the window's character geometry +;; and makes centered content visibly jump. +(add-to-list 'default-frame-alist + `(font . ,(format "Maple Mono NF-%g" + (/ cashmere/font-height 10.0)))) (add-hook 'server-after-make-frame-hook #'cashmere/set-fonts) (cashmere/set-fonts) @@ -2959,6 +2997,11 @@ created later still get them." (use-package textui :ensure (:host github :repo "yibie/textui" :files ("*.el"))) +(use-package fossil-ui + :ensure nil + :after textui + :commands (fossil-ui fossil-ui-status)) + (use-package yggdrasil-ui :ensure nil :after textui @@ -3496,6 +3539,7 @@ workspace (e.g. *scratch*)." "g" '(:ignore t :wk "git") "gc" '(magit-clone :wk "clone") "gg" '(magit-status :wk "status") + "gf" '(fossil-ui-status :wk "fossil status") "gl" '(magit-log-current :wk "log") "gi" '(magit-init :wk "init") "gd" '(xref-find-definitions :wk "go to definition") @@ -3596,7 +3640,8 @@ workspace (e.g. *scratch*)." (general-def '(normal visual operator) 'override :predicate '(not (derived-mode-p 'mu4e-main-mode 'mu4e-headers-mode 'mu4e-view-mode 'mu4e-compose-mode - 'croc-ui-mode 'sync-ui-mode)) + 'croc-ui-mode 'sync-ui-mode + 'fossil-ui-mode)) "s" 'my/s-key-dispatch) @@ -4006,6 +4051,10 @@ reset is unnecessary, so do the handler resolution ourselves and skip (add-hook 'message-send-mail-hook 'mu4e-set-msmtp-account)) +(use-package himalaya-ui + :ensure nil + :commands (himalaya-ui)) + (use-package mu4e-alert :ensure t :after mu4e @@ -4393,4 +4442,37 @@ opening another file in same project does not re-notify." :config (global-javelin-minor-mode 1)) +(use-package clatter + :ensure (:host github :repo "parenworks/clatter.el") + :commands (clatter clatter-quick-connect) + :custom + (clatter-message-order 'oldest-first) + (clatter-notify-enabled t) + (clatter-notify-on-mention t) + (clatter-notify-on-dm t) + (clatter-notify-on-invite t) + (clatter-notify-on-keyword t) + (clatter-notify-keywords '("cashmere")) + (clatter-notify-current-buffer nil) + (clatter-notify-timeout 5000) + (clatter-notify-urgency 'normal) + (clatter-networks + `(("soju" + :server "bouncer.cashmere.rs" + :port 6699 + :tls t + :nick "cashmere" + ;; Bare bouncer username: fans out to every upstream network. + :username "cashmere/libera" + :password ,(password-store-get "soju") + :sasl plain + :bouncer t))) + :config + (require 'gnutls) + (clatter-setup) + (clatter-dcc-setup) + (with-eval-after-load 'org + (require 'clatter-org) + (clatter-org-setup))) + (provide 'init) diff --git a/config.org b/config.org index 9ea7d64..f513a4c 100644 --- a/config.org +++ b/config.org @@ -10,7 +10,7 @@ (setq pgtk-wait-for-event-timeout 0.001) (setq package-enable-at-startup nil) ;; (setq-default mode-line-format t) ;; disabled: boolean t is not valid for mode-line-format -(setq default-frame-alist '((undecorated . t))) +(add-to-list 'default-frame-alist '(undecorated . t)) ;; GC + file-name-handler-alist tuning lives in early-init.el now. (setq create-lockfiles nil) (setq make-backup-files nil) @@ -40,8 +40,30 @@ (defvar my/local-packages nil "Alist of (PACKAGE . DIRECTORY) loaded from a local checkout. Set per-host in the gitignored `local.el'.") + (defvar cashmere/frame-alpha-background nil + "Per-host frame opacity, or nil for the Emacs default.") + (defvar cashmere/font-height 180 + "Per-host default font height in tenths of a point.") + (defvar cashmere/theme nil + "Per-host theme to load, or nil for no theme.") (load (locate-user-emacs-file "local.el") 'noerror 'nomessage)) +;; Apply appearance settings at runtime only. Keeping these outside +;; `eval-and-compile' avoids loading themes or mutating the initial daemon +;; frame while native compilation is inspecting the configuration. +(when cashmere/frame-alpha-background + (add-to-list 'default-frame-alist + `(alpha-background . ,cashmere/frame-alpha-background)) + (when (display-graphic-p) + (set-frame-parameter nil 'alpha-background + cashmere/frame-alpha-background))) + +(when cashmere/theme + (add-to-list 'custom-theme-load-path + (expand-file-name "themes" user-emacs-directory)) + (unless (memq cashmere/theme custom-enabled-themes) + (load-theme cashmere/theme t))) + (dolist (entry my/local-packages) (add-to-list 'load-path (expand-file-name (cdr entry)))) @@ -460,16 +482,16 @@ Selects the compilation window so the cursor lands in it." (defun my/erc-fetch-history (&optional count) "Fetch COUNT previous messages from Soju via CHATHISTORY. -Defaults to 1000 (soju max). With prefix arg, prompts for count. +Defaults to 100 (soju max). With prefix arg, prompts for count. Temporarily disables notifications during the fetch." (interactive "P") (let ((target (erc-default-target))) (if (not target) (message "Not in a channel buffer.") (let ((n (min (if count - (read-number "Messages to fetch: " 1000) - 1000) - 1000))) + (read-number "Messages to fetch: " 100) + 100) + 100))) (erc-notifications-disable) (erc-server-send (format "CHATHISTORY LATEST %s * %d" target n)) (run-at-time 5 nil #'erc-notifications-enable))))) @@ -662,6 +684,11 @@ Temporarily disables notifications during the fetch." (240 . "#74c7ec") (260 . "#89b4fa") (280 . "#b4befe")))) +(use-package vc-fossil + ;; Keep from loading unnecessarily at startup. + :ensure t + ;; This allows VC to load vc-fossil when needed. + :init (add-to-list 'vc-handled-backends 'Fossil t)) #+end_src * ibuffer @@ -2790,13 +2817,17 @@ Auto switch silos (different workspaces/folders) based on preconfigured director #+begin_src emacs-lisp (use-package yasnippet - :ensure t + :ensure (:wait t) + :demand t :config (yas-global-mode 1)) (use-package yasnippet-snippets - :ensure t - :after yasnippet) + :ensure (:wait t) + :demand t + :after yasnippet + :config + (yas-reload-all)) #+end_src ** nix-ts-mode @@ -3472,6 +3503,13 @@ created later still get them." (set-face-attribute 'fixed-pitch frame :family "Maple Mono NF" :weight 'regular) (set-face-attribute 'variable-pitch frame :family "Maple Mono NF" :weight 'regular :height 1.1))) +;; A daemon's first GUI frame must be born with the final font. Applying it +;; only from `server-after-make-frame-hook' lets the compositor show one frame +;; with the fallback font first, which changes the window's character geometry +;; and makes centered content visibly jump. +(add-to-list 'default-frame-alist + `(font . ,(format "Maple Mono NF-%g" + (/ cashmere/font-height 10.0)))) (add-hook 'server-after-make-frame-hook #'cashmere/set-fonts) (cashmere/set-fonts) #+end_src @@ -3592,6 +3630,11 @@ moved to local.el (use-package textui :ensure (:host github :repo "yibie/textui" :files ("*.el"))) +(use-package fossil-ui + :ensure nil + :after textui + :commands (fossil-ui fossil-ui-status)) + (use-package yggdrasil-ui :ensure nil :after textui @@ -4188,6 +4231,7 @@ workspace (e.g. *scratch*)." "g" '(:ignore t :wk "git") "gc" '(magit-clone :wk "clone") "gg" '(magit-status :wk "status") + "gf" '(fossil-ui-status :wk "fossil status") "gl" '(magit-log-current :wk "log") "gi" '(magit-init :wk "init") "gd" '(xref-find-definitions :wk "go to definition") @@ -4288,7 +4332,8 @@ workspace (e.g. *scratch*)." (general-def '(normal visual operator) 'override :predicate '(not (derived-mode-p 'mu4e-main-mode 'mu4e-headers-mode 'mu4e-view-mode 'mu4e-compose-mode - 'croc-ui-mode 'sync-ui-mode)) + 'croc-ui-mode 'sync-ui-mode + 'fossil-ui-mode)) "s" 'my/s-key-dispatch) @@ -4766,6 +4811,14 @@ reset is unnecessary, so do the handler resolution ourselves and skip (add-hook 'message-send-mail-hook 'mu4e-set-msmtp-account)) #+end_src +** Himalaya + +#+begin_src emacs-lisp +(use-package himalaya-ui + :ensure nil + :commands (himalaya-ui)) +#+end_src + ** mu4e-alerts #+begin_src emacs-lisp @@ -5230,6 +5283,45 @@ opening another file in same project does not re-notify." #+end_src +* clatter + +#+begin_src emacs-lisp +(use-package clatter + :ensure (:host github :repo "parenworks/clatter.el") + :commands (clatter clatter-quick-connect) + :custom + (clatter-message-order 'oldest-first) + (clatter-notify-enabled t) + (clatter-notify-on-mention t) + (clatter-notify-on-dm t) + (clatter-notify-on-invite t) + (clatter-notify-on-keyword t) + (clatter-notify-keywords '("cashmere")) + (clatter-notify-current-buffer nil) + (clatter-notify-timeout 5000) + (clatter-notify-urgency 'normal) + (clatter-networks + `(("soju" + :server "bouncer.cashmere.rs" + :port 6699 + :tls t + :nick "cashmere" + ;; Bare bouncer username: fans out to every upstream network. + :username "cashmere/libera" + :password ,(password-store-get "soju") + :sasl plain + :bouncer t))) + :config + (require 'gnutls) + (clatter-setup) + (clatter-dcc-setup) + (with-eval-after-load 'org + (require 'clatter-org) + (clatter-org-setup))) +#+end_src + + + * provide init #+begin_src emacs-lisp diff --git a/custom-vars.el b/custom-vars.el index 4f21c7c..4932943 100644 --- a/custom-vars.el +++ b/custom-vars.el @@ -14,7 +14,13 @@ nushell-ts-mode offlineimap org-modern pdf-tools ultra-scroll)) '(safe-local-variable-values - '((eval let ((host (car (split-string (system-name) "\\.")))) + '((eval add-hook 'after-save-hook + (lambda nil + (when (string-suffix-p ".org" buffer-file-name) + (org-md-export-to-markdown))) + nil t) + (org-md-headline-style . atx) + (eval let ((host (car (split-string (system-name) "\\.")))) (setq-local eglot-workspace-configuration `(:nixd (:nixpkgs diff --git a/lisp/fossil-ui.el b/lisp/fossil-ui.el new file mode 100644 index 0000000..0982e4b --- /dev/null +++ b/lisp/fossil-ui.el @@ -0,0 +1,1283 @@ +;;; fossil-ui.el --- Small TextUI frontend for Fossil -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 cashmere + +;; Author: cashmere +;; Version: 0.1.0 +;; Package-Requires: ((emacs "29.1") (textui "0.5.1")) +;; Keywords: tools, vc + +;;; Commentary: + +;; A deliberately small Fossil dashboard. It follows Fossil's own model: +;; files may be selected for a partial commit, but there is no staging area. +;; Local inspection is synchronous; operations which may trigger autosync run +;; asynchronously. + +;;; Code: + +(require 'ansi-color) +(require 'cl-lib) +(require 'diff-mode) +(require 'json) +(require 'outline) +(require 'seq) +(require 'subr-x) +(require 'textui) +(require 'textui-widgets) + +(declare-function evil-define-key* "evil-core" (state keymap key def &rest bindings)) +(declare-function evil-get-auxiliary-keymap "evil-core" + (map state &optional create noinherit)) +(declare-function evil-make-intercept-map "evil-core" (keymap &optional state aux)) +(declare-function evil-normalize-keymaps "evil-core" (&optional state)) +(declare-function evil-set-initial-state "evil-core" (mode state)) +(declare-function general-define-key "general" (&rest args)) +(declare-function general-local-map "general" ()) +(defvar general-override-local-mode-map) + +(defgroup fossil-ui nil + "A compact TextUI frontend for Fossil." + :group 'tools + :prefix "fossil-ui-") + +(defcustom fossil-ui-program "fossil" + "Fossil executable used by the dashboard." + :type 'string + :group 'fossil-ui) + +(defcustom fossil-ui-timeline-limit 25 + "Maximum number of recent check-ins loaded for the dashboard." + :type 'integer + :group 'fossil-ui) + +(defcustom fossil-ui-content-width nil + "Optional maximum width of dashboard content in columns. +Nil, the default, uses the complete TextUI window width. Set an integer only +when a deliberately compact dashboard is preferred." + :type '(choice (const :tag "Use full window width" nil) + (integer :tag "Maximum columns")) + :group 'fossil-ui) + +(defcustom fossil-ui-use-icons 'auto + "Whether to use Nerd Font icons in the dashboard. +When set to `auto', use them only in graphical displays when nerd-icons is +already loaded. Nil always uses portable text symbols." + :type '(choice (const :tag "Automatically" auto) + (const :tag "Always" t) + (const :tag "Never" nil)) + :group 'fossil-ui) + +(defcustom fossil-ui-timeline-minimum 8 + "Minimum number of timeline entries shown when available." + :type 'integer + :group 'fossil-ui) + +(defcustom fossil-ui-diff-renderer 'auto + "Renderer used for working-tree diffs. +`auto' uses Delta when available and otherwise keeps the plain Fossil diff. +`delta' requires `fossil-ui-delta-program' to be executable. `plain' never +runs an external renderer." + :type '(choice (const :tag "Delta when available" auto) + (const :tag "Always Delta" delta) + (const :tag "Plain Fossil diff" plain)) + :group 'fossil-ui) + +(defcustom fossil-ui-delta-program "delta" + "Delta executable used to render Fossil diffs." + :type 'string + :group 'fossil-ui) + +(defcustom fossil-ui-delta-arguments '("--paging=never" "--color-only") + "Arguments passed to Delta after the Fossil diff on standard input." + :type '(repeat string) + :group 'fossil-ui) + +(defface fossil-ui-strong '((t :inherit bold)) + "Structural text." + :group 'fossil-ui) + +(defface fossil-ui-faded '((t :inherit shadow)) + "Secondary text." + :group 'fossil-ui) + +(defface fossil-ui-salient '((t :inherit link)) + "Selected and actionable text." + :group 'fossil-ui) + +(defface fossil-ui-warning '((t :inherit warning)) + "Changed or noteworthy state." + :group 'fossil-ui) + +(defface fossil-ui-critical '((t :inherit error)) + "Conflicts and command errors." + :group 'fossil-ui) + +(defface fossil-ui-selected '((t :inherit highlight :weight bold)) + "Current file row." + :group 'fossil-ui) + +(defun fossil-ui--measure-row (widget) + "Return the visible single-line value of file-row WIDGET." + (format "%s" (or (widget-get widget :value) ""))) + +(defun fossil-ui--attach-row (widget from to) + "Attach file-row WIDGET to the TextUI text between FROM and TO." + (textui-widgets-attach-button widget from to) + (add-text-properties + from to + (list 'fossil-ui-path (widget-get widget :fossil-ui-path) + 'fossil-ui-status (widget-get widget :fossil-ui-status)))) + +(define-widget 'fossil-ui-row 'push-button + "A flat, clickable Fossil file row." + :format "%v" + :button-face 'default + :textui-measure #'fossil-ui--measure-row + :textui-attach #'fossil-ui--attach-row) + +(define-widget 'fossil-ui-keycap 'push-button + "A flat keycap and label action." + :format "%v" + :button-face 'default + :textui-measure #'fossil-ui--measure-row + :textui-attach #'textui-widgets-attach-button) + +(defvar fossil-ui--commit-history nil) +(defvar-local fossil-ui--process nil) +(defvar-local fossil-ui--commit-owner nil) +(defvar-local fossil-ui--commit-paths nil) +(defvar-local fossil-ui--window-height nil) + +(defun fossil-ui--call-in (directory &rest args) + "Run Fossil ARGS synchronously in DIRECTORY and return (CODE OUTPUT)." + (with-temp-buffer + (let ((default-directory (file-name-as-directory directory))) + (list (condition-case err + (apply #'process-file fossil-ui-program nil (list t t) nil args) + (file-missing + (insert (error-message-string err)) + 127) + (error + (insert (error-message-string err)) + 1)) + (string-trim-right (buffer-string)))))) + +(defun fossil-ui--require-success (directory &rest args) + "Run Fossil ARGS in DIRECTORY and return output or signal a user error." + (pcase-let ((`(,code ,output) (apply #'fossil-ui--call-in directory args))) + (if (zerop code) + output + (user-error "%s" (if (string-empty-p output) + (format "Fossil exited with status %d" code) + output))))) + +(defun fossil-ui--input-directory (&optional directory) + "Return a usable starting directory for DIRECTORY or the current buffer." + (file-name-as-directory + (expand-file-name + (or directory + (and buffer-file-name (file-name-directory buffer-file-name)) + default-directory)))) + +(defun fossil-ui--checkout-info (directory) + "Return checkout metadata for DIRECTORY, or signal a user error." + (let ((output (fossil-ui--require-success directory "info")) + result) + (dolist (line (split-string output "\n" t)) + (when (string-match "\\`\\([^:[:space:]]+\\):[[:space:]]*\\(.*\\)\\'" line) + (setq result + (plist-put result + (intern (concat ":" (match-string 1 line))) + (string-trim (match-string 2 line)))))) + (unless (plist-get result :local-root) + (user-error "%s is not inside an open Fossil checkout" directory)) + (plist-put result :root + (file-name-as-directory (plist-get result :local-root))))) + +(defun fossil-ui--json-command (root &rest args) + "Run Fossil JSON command ARGS at ROOT and return its payload." + (let* ((output (apply #'fossil-ui--require-success root "json" args)) + (data (condition-case err + (json-parse-string output + :object-type 'alist + :array-type 'list + :null-object nil + :false-object nil) + (error + (user-error "Invalid Fossil JSON: %s" + (error-message-string err)))))) + (or (alist-get 'payload data) + (user-error "Fossil JSON response has no payload")))) + +(defun fossil-ui--parse-change-line (line) + "Parse one Fossil changes LINE into a plist." + (when (string-match "\\`\\([A-Z_]+\\)[[:space:]]+\\(.*\\)\\'" line) + (let* ((status (match-string 1 line)) + (raw (match-string 2 line)) + (parts (condition-case nil + (split-string-and-unquote raw) + (error (list raw)))) + (path (mapconcat #'identity parts " "))) + (list :status status :path path)))) + +(defun fossil-ui--changes (root) + "Return changed and unmanaged files below ROOT." + (let ((output (fossil-ui--require-success + root "changes" "--hash" "--classify" "--differ" "--rel-paths"))) + (delq nil (mapcar #'fossil-ui--parse-change-line + (split-string output "\n" t))))) + +(defun fossil-ui--parse-numstat-line (line) + "Parse one Fossil diff --numstat LINE into a plist. +Paths may contain spaces. A dash in either count denotes binary data." + (when (and + (string-match + "\\`[\t ]*\\([0-9]+\\|-\\)[\t ]+\\([0-9]+\\|-\\)[\t ]+\\(.*\\)\\'" + line) + (not (string-prefix-p "TOTAL " (match-string 3 line)))) + (let ((insertions (match-string 1 line)) + (deletions (match-string 2 line)) + (path (match-string 3 line))) + (list :path (string-remove-prefix "./" path) + :insertions (unless (string= insertions "-") + (string-to-number insertions)) + :deletions (unless (string= deletions "-") + (string-to-number deletions)) + :binary (or (string= insertions "-") (string= deletions "-")))))) + +(defun fossil-ui--numstat (root) + "Return a hash table of diff statistics keyed by relative path at ROOT." + (let ((table (make-hash-table :test #'equal))) + (pcase-let ((`(,code ,output) + (fossil-ui--call-in root "diff" "--numstat" "--internal"))) + (when (zerop code) + (dolist (line (split-string output "\n" t)) + (when-let* ((stat (fossil-ui--parse-numstat-line line))) + (puthash (plist-get stat :path) stat table))))) + table)) + +(defun fossil-ui--attach-numstat (changes stats) + "Copy CHANGES and attach matching insertion/deletion data from STATS." + (mapcar + (lambda (change) + (let* ((next (copy-sequence change)) + (stat (gethash (plist-get change :path) stats))) + (if stat + (progn + (setq next (plist-put next :insertions (plist-get stat :insertions))) + (setq next (plist-put next :deletions (plist-get stat :deletions))) + (when (plist-get stat :binary) + (setq next (plist-put next :binary t)))) + (when (string= (plist-get change :status) "EXTRA") + (setq next (plist-put next :extra t)))) + next)) + changes)) + +(defun fossil-ui--setting (root name) + "Return Fossil setting NAME at ROOT." + (pcase-let ((`(,code ,output) (fossil-ui--call-in root "settings"))) + (if (not (zerop code)) + "unknown" + (if-let* ((line (cl-find-if + (lambda (candidate) + (string-match-p + (format "\\`%s\\(?:[[:space:]]\\|\\'\\)" + (regexp-quote name)) + candidate)) + (split-string output "\n" t))) + (parts (split-string line))) + (or (nth 2 parts) "on") + "unknown")))) + +(defun fossil-ui--remote (root) + "Return the default Fossil remote at ROOT." + (pcase-let ((`(,code ,output) (fossil-ui--call-in root "remote" "list"))) + (if (or (not (zerop code)) (string-empty-p output)) + nil + (let ((line (car (split-string output "\n" t)))) + (if (string-match "^[[:space:]]*\\([^[:space:]]+\\)[[:space:]]+\\(.*\\)$" line) + (match-string 2 line) + line))))) + +(defun fossil-ui--timeline (root) + "Return recent check-ins at ROOT." + (let* ((payload (fossil-ui--json-command + root "timeline" "checkin" + "--limit" (number-to-string fossil-ui-timeline-limit))) + (entries (alist-get 'timeline payload))) + (or entries nil))) + +(defun fossil-ui--branches (root) + "Return open branch names at ROOT." + (let* ((payload (fossil-ui--json-command root "branch" "list")) + (branches (alist-get 'branches payload))) + (sort (copy-sequence (or branches nil)) #'string-lessp))) + +(defun fossil-ui--snapshot (directory &optional selected) + "Collect dashboard state for DIRECTORY, retaining SELECTED paths." + (let* ((info (fossil-ui--checkout-info directory)) + (root (plist-get info :root)) + (changes (fossil-ui--attach-numstat + (fossil-ui--changes root) (fossil-ui--numstat root))) + (paths (mapcar (lambda (change) (plist-get change :path)) changes))) + (list :root root + :repository (plist-get info :repository) + :checkout (plist-get info :checkout) + :branch (or (plist-get info :tags) "trunk") + :user (plist-get info :user) + :remote (fossil-ui--remote root) + :autosync (fossil-ui--setting root "autosync") + :changes changes + :selected (cl-remove-if-not (lambda (path) (member path paths)) selected) + :timeline (condition-case err + (fossil-ui--timeline root) + (error (list (list (cons 'comment + (error-message-string err)))))) + :branches (condition-case nil (fossil-ui--branches root) (error nil)) + :height fossil-ui--window-height + :busy nil + :error nil))) + +(defun fossil-ui--fit (value width &optional face) + "Return VALUE truncated or padded to WIDTH, optionally using FACE." + (let* ((width (max 0 width)) + (value (truncate-string-to-width (format "%s" (or value "")) + width nil nil "...")) + (result (concat value + (make-string (max 0 (- width (string-width value))) ?\s)))) + (if face (propertize result 'face face) result))) + +(defun fossil-ui--item (value &optional face) + "Return a TextUI item for VALUE with optional FACE." + `(:type item :format "%v" + :value ,(if face (propertize value 'face face) value))) + +(defun fossil-ui--icons-p () + "Return non-nil when dashboard Nerd Font icons should be used." + (pcase fossil-ui-use-icons + ('auto (and (display-graphic-p) (featurep 'nerd-icons))) + ((pred null) nil) + (_ t))) + +(defun fossil-ui--icon (kind) + "Return a small icon for KIND, with a portable fallback." + (let ((icons '((repository . "󰆼") (branch . "󰘬") (sync . "󰓦") + (edited . "󰏫") (added . "󰐕") (deleted . "󰍵") + (extra . "󰋗") (conflict . "󰀦") (missing . "󰅖"))) + (fallbacks '((repository . "R") (branch . "B") (sync . "S") + (edited . "~") (added . "+") (deleted . "-") + (extra . "?") (conflict . "!") (missing . "!")))) + (or (alist-get kind (if (fossil-ui--icons-p) icons fallbacks)) "·"))) + +(defun fossil-ui--keycap (key label action focus-id &optional disabled) + "Return a flat KEY LABEL control for ACTION with stable FOCUS-ID. +When DISABLED is non-nil, retain the control but render it quietly." + (let* ((face (if disabled 'fossil-ui-faded 'default)) + (value (concat (propertize (format " %s " key) + 'face (if disabled 'shadow 'highlight)) + (propertize label 'face face)))) + `(:type fossil-ui-keycap + :value ,value + :inactive ,disabled + :layout (:focus-id ,focus-id) + :action ,(lambda (&rest _) + (unless disabled (call-interactively action)))))) + +(defun fossil-ui--status-face (status) + "Return a face for Fossil STATUS." + (cond + ((member status '("CONFLICT" "MISSING")) 'fossil-ui-critical) + ((member status '("EXTRA" "ADDED" "DELETED")) 'fossil-ui-salient) + (t 'fossil-ui-warning))) + +(defun fossil-ui--status-icon (status) + "Return an icon representing Fossil STATUS." + (fossil-ui--icon + (pcase status + ("EDITED" 'edited) ("ADDED" 'added) ("DELETED" 'deleted) + ("EXTRA" 'extra) ("CONFLICT" 'conflict) ("MISSING" 'missing) + (_ 'edited)))) + +(defun fossil-ui--change-stat (change) + "Return a compact human-readable statistic for CHANGE." + (cond + ((plist-get change :extra) "untracked") + ((plist-get change :binary) "binary") + ((or (numberp (plist-get change :insertions)) + (numberp (plist-get change :deletions))) + (format "+%d −%d" (or (plist-get change :insertions) 0) + (or (plist-get change :deletions) 0))) + (t "—"))) + +(defun fossil-ui--change-row (change width selected &optional narrow) + "Render CHANGE at WIDTH, using SELECTED paths. +When NARROW is non-nil return a primary row without trailing metadata." + (let* ((status (plist-get change :status)) + (path (plist-get change :path)) + (marked (member path selected)) + (metadata (format "%s %s" status (fossil-ui--change-stat change))) + (meta-width (string-width metadata)) + (path-width (max 10 (- width meta-width 9))) + (line (concat (propertize "▎" 'face (fossil-ui--status-face status)) + (if marked "[x] " "[ ] ") + (propertize (concat (fossil-ui--status-icon status) " ") + 'face (fossil-ui--status-face status)) + (fossil-ui--fit path (if narrow (- width 7) path-width) + (if marked 'fossil-ui-salient 'default)) + (unless narrow + (propertize metadata 'face + (fossil-ui--status-face status)))))) + `(:type fossil-ui-row + :value ,line + :fossil-ui-path ,path + :fossil-ui-status ,status + :layout (:focus-id ,(list 'file path)) + :action ,(lambda (&rest _) (fossil-ui-diff))))) + +(defun fossil-ui--change-elements (change width selected) + "Return responsive dashboard elements for CHANGE." + (if (< width 90) + (list (fossil-ui--change-row change width selected t) + (fossil-ui--item + (fossil-ui--fit + (format " %s · %s" (plist-get change :status) + (fossil-ui--change-stat change)) width) + 'fossil-ui-faded)) + (list (fossil-ui--change-row change width selected)))) + +(defun fossil-ui--short-checkout (checkout) + "Return a short check-in identifier from CHECKOUT." + (if (and checkout (string-match "\\`\\([[:xdigit:]]+\\)" checkout)) + (substring (match-string 1 checkout) + 0 (min 10 (length (match-string 1 checkout)))) + "unknown")) + +(defun fossil-ui--timeline-elements (entry width) + "Render timeline ENTRY at WIDTH as a two-line rail." + (let* ((uuid (or (alist-get 'uuid entry) "")) + (short (substring uuid 0 (min 10 (length uuid)))) + (timestamp (alist-get 'timestamp entry)) + (date (if (numberp timestamp) + (format-time-string "%b %d %H:%M" (seconds-to-time timestamp)) + "unknown time")) + (user (or (alist-get 'user entry) "")) + (comment (or (alist-get 'comment entry) "")) + (tags (or (alist-get 'tags entry) (alist-get 'branch entry))) + (tag-text (cond ((listp tags) (mapconcat (lambda (tag) (format "%s" tag)) + tags ", ")) + (tags (format "%s" tags)) (t ""))) + (author (truncate-string-to-width user 18 nil nil "…"))) + (list + (fossil-ui--item + (concat (propertize "● " 'face 'fossil-ui-salient) + (fossil-ui--fit comment (max 12 (- width 16))) + " " + (propertize date 'face 'fossil-ui-faded))) + (fossil-ui--item + (fossil-ui--fit + (format "│ %s %s%s" short author + (if (string-empty-p tag-text) "" (concat " · " tag-text))) width) + 'fossil-ui-faded)))) + +(defun fossil-ui--timeline-count () + "Return the number of loaded timeline rows suitable for current height." + (let* ((height (or (plist-get textui-state :height) 32)) + (available (max fossil-ui-timeline-minimum (floor (/ (- height 14) 2))))) + (min fossil-ui-timeline-limit (max fossil-ui-timeline-minimum available)))) + +(defun fossil-ui--chip (text face) + "Return a compact status chip with TEXT and FACE." + (propertize (format " %s " text) 'face face)) + +(defconst fossil-ui--wide-layout-width 115 + "Minimum width for side-by-side changes and commit panels.") + +(defconst fossil-ui--metadata-minimum-width 24 + "Minimum outer width of a repository metadata card.") + +(defun fossil-ui--column (children) + "Return a tightly stacked TextUI column containing CHILDREN." + `(:type :flex :direction :column :gap 0 :children ,children)) + +(defun fossil-ui--card (title children width &optional minimum grow) + "Return a padded card named TITLE containing CHILDREN at WIDTH. +MINIMUM and GROW are parent-facing Flex sizing hints." + `(:type :flex :direction :column :gap 1 :padding 1 :border t + :layout (:width ,width :min-width ,(or minimum width) :grow ,(or grow 0)) + :children (,(fossil-ui--item + title (unless (get-text-property 0 'face title) + 'fossil-ui-strong)) + ,(fossil-ui--column children)))) + +(defun fossil-ui--metadata-columns (width) + "Return the responsive metadata grid column count for WIDTH." + (min 3 (max 1 (/ (1+ width) (1+ fossil-ui--metadata-minimum-width))))) + +(defun fossil-ui--metadata-track-width (width) + "Return a conservative equal metadata track width for WIDTH." + (let ((columns (fossil-ui--metadata-columns width))) + (/ (- width (1- columns)) columns))) + +(defun fossil-ui--metadata-grid (width chips) + "Return repository metadata cards for WIDTH using status CHIPS." + (let* ((root (plist-get textui-state :root)) + (repository (plist-get textui-state :repository)) + (remote (plist-get textui-state :remote)) + (track-width (fossil-ui--metadata-track-width width)) + (inner-width (max 8 (- track-width 4))) + (card-layout (list track-width fossil-ui--metadata-minimum-width 1))) + `(:type :grid :columns 3 + :min-column-width ,fossil-ui--metadata-minimum-width :gap 1 + :children + (,(apply #'fossil-ui--card + "Repository" + (list + (fossil-ui--item + (fossil-ui--fit (abbreviate-file-name root) inner-width)) + (fossil-ui--item + (fossil-ui--fit (abbreviate-file-name + (or repository "unknown repository")) + inner-width) + 'fossil-ui-faded) + (fossil-ui--item " ")) + card-layout) + ,(apply #'fossil-ui--card + "Checkout" + (list + (fossil-ui--item + (fossil-ui--fit + (format "%s %s" (fossil-ui--icon 'branch) + (plist-get textui-state :branch)) inner-width) + 'fossil-ui-salient) + (fossil-ui--item + (fossil-ui--fit + (format "commit %s" + (fossil-ui--short-checkout + (plist-get textui-state :checkout))) inner-width) + 'fossil-ui-faded) + (fossil-ui--item (fossil-ui--fit chips inner-width))) + card-layout) + ,(apply #'fossil-ui--card + "Synchronization" + (list + (fossil-ui--item + (fossil-ui--fit + (format "autosync %s" (plist-get textui-state :autosync)) + inner-width)) + (fossil-ui--item + (fossil-ui--fit + (format "%s %s" (fossil-ui--icon 'sync) + (or remote "no remote")) inner-width) + (if remote 'link 'fossil-ui-faded)) + (fossil-ui--item " ")) + card-layout))))) + +(defun fossil-ui--changes-panel (outer-width changes selected) + "Return the changed-files card at OUTER-WIDTH." + (let* ((inner-width (max 8 (- outer-width 4))) + (title (format "Changes %d · Selected %d" + (length changes) (length selected))) + (body (if changes + (mapcan (lambda (change) + (fossil-ui--change-elements + change inner-width selected)) changes) + (list (fossil-ui--item "✓ Working checkout is clean" + 'success))))) + (fossil-ui--card title body outer-width outer-width 0))) + +(defun fossil-ui--commits-panel (outer-width timeline) + "Return the recent-commits card at OUTER-WIDTH using TIMELINE." + (let ((inner-width (max 8 (- outer-width 4)))) + (fossil-ui--card + "Recent commits" + (if timeline + (mapcan (lambda (entry) + (fossil-ui--timeline-elements entry inner-width)) timeline) + (list (fossil-ui--item "No commits available" 'fossil-ui-faded))) + outer-width outer-width 0))) + +(defun fossil-ui--main-panels (width changes selected timeline) + "Return responsive work panels for WIDTH and dashboard data." + (if (>= width fossil-ui--wide-layout-width) + (let* ((available (1- width)) + (changes-width (floor (* available 0.64))) + (commits-width (- available changes-width))) + `(:type :flex :direction :row :gap 1 + :children (,(fossil-ui--changes-panel changes-width changes selected) + ,(fossil-ui--commits-panel commits-width timeline)))) + `(:type :flex :direction :column :gap 1 + :children (,(fossil-ui--changes-panel width changes selected) + ,(fossil-ui--commits-panel width timeline))))) + +(defun fossil-ui--banner (title message width face) + "Return a full-width status banner with TITLE, MESSAGE and FACE." + (fossil-ui--card + (propertize title 'face face) + (list (fossil-ui--item (fossil-ui--fit message (max 8 (- width 4))) face)) + width width 0)) + +(defun fossil-ui--screen-elements (width) + "Return dashboard elements for WIDTH." + (let* ((root (plist-get textui-state :root)) + (changes (plist-get textui-state :changes)) + (selected (plist-get textui-state :selected)) + (busy (plist-get textui-state :busy)) + (error-text (plist-get textui-state :error)) + (remote-value (plist-get textui-state :remote)) + (project (file-name-nondirectory (directory-file-name root))) + (timeline (seq-take (plist-get textui-state :timeline) + (fossil-ui--timeline-count))) + (chips (concat + (fossil-ui--chip (if changes (format "%d changed" (length changes)) + "clean") + (if changes 'warning 'success)) + " " + (when selected + (concat (fossil-ui--chip (format "%d selected" (length selected)) + 'highlight) " ")) + (when busy (fossil-ui--chip (format "running: %s" busy) 'warning)) + (when error-text (fossil-ui--chip "error" 'error))))) + (append + (list + (fossil-ui--item + (fossil-ui--fit + (format "%s %s" (fossil-ui--icon 'repository) project) width) + 'fossil-ui-strong) + `(:type :flex :direction :row :gap 1 + :children + (,(fossil-ui--keycap "g" "Refresh" #'fossil-ui-refresh 'refresh) + ,(fossil-ui--keycap "c" "Commit" #'fossil-ui-commit 'commit) + ,(fossil-ui--keycap "u" "Update" #'fossil-ui-update 'update) + ,(fossil-ui--keycap "s" "Sync" #'fossil-ui-sync 'sync (not remote-value)) + ,(fossil-ui--keycap "b" "Branch" #'fossil-ui-switch-branch 'branch))) + (fossil-ui--metadata-grid width chips)) + (when busy + (list (fossil-ui--banner "Running" (format "%s is running…" busy) + width 'fossil-ui-warning))) + (when error-text + (list (fossil-ui--banner "Error" error-text width 'fossil-ui-critical))) + (list + (fossil-ui--main-panels width changes selected timeline) + (fossil-ui--item "? Help · q Close" 'fossil-ui-faded))))) + +(defun fossil-ui--frame (width) + "Render the Fossil dashboard at WIDTH." + (let ((content-width + (max 1 (if fossil-ui-content-width + (min width fossil-ui-content-width) + width)))) + (list `(:type :flex :direction :column :gap 1 + :layout (:width ,content-width) + :children ,(fossil-ui--screen-elements content-width))))) + +(defun fossil-ui--path-at-point () + "Return the Fossil path at point." + (or (get-text-property (point) 'fossil-ui-path) + (get-text-property (line-beginning-position) 'fossil-ui-path))) + +(defun fossil-ui--status-at-point () + "Return the Fossil status at point." + (or (get-text-property (point) 'fossil-ui-status) + (get-text-property (line-beginning-position) 'fossil-ui-status))) + +(defun fossil-ui--goto-path (path) + "Move point to PATH when it is visible." + (goto-char (point-min)) + (when-let* ((match (text-property-search-forward + 'fossil-ui-path path #'equal))) + (goto-char (prop-match-beginning match)))) + +(defun fossil-ui-next-file () + "Move to the next changed file, wrapping at the bottom." + (interactive) + (let ((origin (point))) + (goto-char (min (point-max) (1+ (line-end-position)))) + (if-let* ((match (text-property-search-forward + 'fossil-ui-path nil nil t))) + (goto-char (prop-match-beginning match)) + (goto-char (point-min)) + (if-let* ((first (text-property-search-forward + 'fossil-ui-path nil nil t))) + (goto-char (prop-match-beginning first)) + (goto-char origin) + (message "No changed files"))))) + +(defun fossil-ui-previous-file () + "Move to the previous changed file, wrapping at the top." + (interactive) + (let (positions) + (save-excursion + (goto-char (point-min)) + (while-let ((match (text-property-search-forward + 'fossil-ui-path nil nil t))) + (push (prop-match-beginning match) positions) + (goto-char (prop-match-end match)))) + (setq positions (nreverse positions)) + (if-let* ((target (or (car (last (cl-remove-if-not + (lambda (position) (< position (point))) + positions))) + (car (last positions))))) + (goto-char target) + (message "No changed files")))) + +(defun fossil-ui-refresh () + "Refresh the current Fossil dashboard." + (interactive) + (when (plist-get textui-state :busy) + (user-error "Fossil is busy: %s" (plist-get textui-state :busy))) + (let ((path (fossil-ui--path-at-point)) + (selected (plist-get textui-state :selected)) + (root (plist-get textui-state :root))) + (condition-case err + (let ((next (fossil-ui--snapshot root selected))) + (textui-update (current-buffer) (lambda (_) next)) + (when path (fossil-ui--goto-path path))) + (error + (textui-set-state (current-buffer) :error (error-message-string err)))))) + +(defun fossil-ui-toggle-mark () + "Toggle the commit mark on the file at point." + (interactive) + (let ((path (or (fossil-ui--path-at-point) (user-error "No file at point"))) + (status (fossil-ui--status-at-point))) + (when (string= status "EXTRA") + (user-error "Add this file before selecting it for a commit")) + (textui-update + (current-buffer) + (lambda (state) + (let* ((next (copy-sequence state)) + (selected (copy-sequence (plist-get state :selected)))) + (plist-put next :selected + (if (member path selected) + (delete path selected) + (append selected (list path))))))) + (fossil-ui--goto-path path))) + +(defun fossil-ui-mark-all () + "Select all managed changes for commit." + (interactive) + (textui-set-state + (current-buffer) :selected + (mapcar (lambda (change) (plist-get change :path)) + (cl-remove-if (lambda (change) + (string= (plist-get change :status) "EXTRA")) + (plist-get textui-state :changes))))) + +(defun fossil-ui-unmark-all () + "Clear all commit selections." + (interactive) + (textui-set-state (current-buffer) :selected nil)) + +(defun fossil-ui--show-output (title output &optional mode) + "Show OUTPUT in a buffer named TITLE, optionally enabling MODE." + (let ((buffer (get-buffer-create title))) + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (erase-buffer) + (insert output) + (goto-char (point-min)) + (funcall (or mode #'special-mode)))) + (pop-to-buffer buffer) + buffer)) + +(defvar fossil-ui-diff-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map diff-mode-map) + (define-key map (kbd "]c") #'diff-hunk-next) + (define-key map (kbd "[c") #'diff-hunk-prev) + (define-key map (kbd "TAB") #'outline-toggle-children) + (define-key map (kbd "q") #'quit-window) + map)) + +(defconst fossil-ui--diff-evil-bindings + '(("]c" . diff-hunk-next) + ("[c" . diff-hunk-prev) + ("TAB" . outline-toggle-children) + ("q" . quit-window)) + "Bindings which a Fossil diff buffer owns in modal states.") + +(define-derived-mode fossil-ui-diff-mode diff-mode "Fossil-Diff" + "Mode for a Fossil working-tree diff." + (setq-local outline-regexp "^@@ ") + (outline-minor-mode 1) + (setq buffer-read-only t) + (when (fboundp 'general-define-key) + (fossil-ui--install-general-local-map fossil-ui--diff-evil-bindings)) + (when (fboundp 'evil-normalize-keymaps) + (evil-normalize-keymaps))) + +(defun fossil-ui--delta-render (diff) + "Render unified DIFF through Delta and return propertized Emacs text. +Return nil when Delta exits unsuccessfully." + (with-temp-buffer + (insert diff) + (let ((code (condition-case nil + (apply #'call-process-region + (point-min) (point-max) + fossil-ui-delta-program t t nil + fossil-ui-delta-arguments) + (file-missing 127) + (error 1)))) + (when (zerop code) + (let* ((rendered (ansi-color-apply (buffer-string))) + (position 0) + (limit (length rendered))) + ;; `ansi-color-apply' uses `font-lock-face'. Promote Delta's faces + ;; to ordinary `face' properties so diff-mode fontification cannot + ;; overwrite them later. + (while (< position limit) + (let* ((next (next-single-property-change + position 'font-lock-face rendered limit)) + (face (get-text-property position 'font-lock-face rendered))) + (when face + (add-text-properties position next (list 'face face) rendered) + (remove-text-properties position next '(font-lock-face nil) + rendered)) + (setq position next))) + rendered))))) + +(defun fossil-ui--render-diff (diff) + "Render unified DIFF according to `fossil-ui-diff-renderer'." + (pcase fossil-ui-diff-renderer + ('plain diff) + ('delta + (or (and (executable-find fossil-ui-delta-program) + (fossil-ui--delta-render diff)) + (user-error "Delta could not render this diff"))) + ('auto + (or (and (executable-find fossil-ui-delta-program) + (fossil-ui--delta-render diff)) + diff)) + (_ (user-error "Unknown Fossil diff renderer: %S" + fossil-ui-diff-renderer)))) + +(defun fossil-ui-diff () + "Show the diff for the file at point." + (interactive) + (let* ((path (or (fossil-ui--path-at-point) (user-error "No file at point"))) + (status (fossil-ui--status-at-point)) + (root (plist-get textui-state :root)) + (result (if (string= status "EXTRA") + (fossil-ui--call-in root "xdiff" path) + (fossil-ui--call-in root "diff" "--internal" "--unified" "--" path))) + (code (car result)) + (output (cadr result))) + (unless (zerop code) + (user-error "%s" output)) + (fossil-ui--show-output + (format "*fossil diff: %s*" path) + (if (string-empty-p output) + "No textual diff available.\n" + (fossil-ui--render-diff output)) + #'fossil-ui-diff-mode))) + +(defun fossil-ui-visit-file () + "Visit the file at point." + (interactive) + (find-file (expand-file-name + (or (fossil-ui--path-at-point) (user-error "No file at point")) + (plist-get textui-state :root)))) + +(defun fossil-ui-add () + "Add the unversioned file at point to Fossil." + (interactive) + (let ((path (or (fossil-ui--path-at-point) (user-error "No file at point")))) + (unless (string= (fossil-ui--status-at-point) "EXTRA") + (user-error "%s is already managed" path)) + (fossil-ui--require-success (plist-get textui-state :root) "add" "--" path) + (fossil-ui-refresh) + (fossil-ui--goto-path path) + (message "Added %s" path))) + +(defun fossil-ui-forget () + "Stop tracking the file at point without deleting it." + (interactive) + (let ((path (or (fossil-ui--path-at-point) (user-error "No file at point")))) + (when (string= (fossil-ui--status-at-point) "EXTRA") + (user-error "%s is not tracked" path)) + (when (yes-or-no-p (format "Stop tracking %s? The disk file stays. " path)) + (fossil-ui--require-success (plist-get textui-state :root) "forget" "--" path) + (fossil-ui-refresh) + (message "Stopped tracking %s" path)))) + +(defun fossil-ui--selected-or-current () + "Return selected paths, or the path at point when none are selected." + (or (copy-sequence (plist-get textui-state :selected)) + (and-let* ((path (fossil-ui--path-at-point))) (list path)) + (user-error "No files selected"))) + +(defun fossil-ui-revert () + "Revert selected files, or the file at point." + (interactive) + (let ((paths (fossil-ui--selected-or-current))) + (when (yes-or-no-p + (format "Revert %d file%s? Fossil undo can restore this once. " + (length paths) (if (= (length paths) 1) "" "s"))) + (apply #'fossil-ui--require-success + (plist-get textui-state :root) "revert" "--" paths) + (fossil-ui-refresh) + (message "Reverted %d file(s)" (length paths))))) + +(defun fossil-ui-undo () + "Preview and run Fossil's one-level undo." + (interactive) + (let* ((root (plist-get textui-state :root)) + (preview (fossil-ui--require-success root "undo" "--dry-run"))) + (if (string-empty-p preview) + (message "Fossil has nothing to undo") + (when (yes-or-no-p (format "%s\nRun this undo? " preview)) + (fossil-ui--require-success root "undo") + (fossil-ui-refresh) + (message "Fossil undo completed"))))) + +(defun fossil-ui--async (label args &optional on-success) + "Run Fossil ARGS asynchronously, displaying LABEL while active." + (when (or (plist-get textui-state :busy) + (and fossil-ui--process (process-live-p fossil-ui--process))) + (user-error "Fossil is already busy")) + (let* ((owner (current-buffer)) + (root (plist-get textui-state :root)) + (output-buffer (generate-new-buffer (format " *fossil-ui:%s*" label)))) + (textui-update owner + (lambda (state) + (let ((next (copy-sequence state))) + (setq next (plist-put next :busy label)) + (plist-put next :error nil)))) + (let ((default-directory root)) + (setq fossil-ui--process + (make-process + :name (format "fossil-ui-%s" label) + :buffer output-buffer + :command (cons fossil-ui-program args) + :noquery t + :sentinel + (lambda (process _event) + (when (memq (process-status process) '(exit signal)) + (let ((code (process-exit-status process)) + (output (with-current-buffer (process-buffer process) + (string-trim (buffer-string))))) + (when (buffer-live-p (process-buffer process)) + (kill-buffer (process-buffer process))) + (when (buffer-live-p owner) + (with-current-buffer owner + (setq fossil-ui--process nil) + (if (zerop code) + (progn + (textui-set-state owner :busy nil) + (fossil-ui-refresh) + (when on-success (funcall on-success output)) + (message "Fossil %s completed%s" + label + (if (string-empty-p output) "" + (format ": %s" output)))) + (textui-update + owner + (lambda (state) + (let ((next (copy-sequence state))) + (setq next (plist-put next :busy nil)) + (plist-put next :error + (if (string-empty-p output) + (format "%s exited %d" label code) + output))))) + (fossil-ui--show-output + (format "*fossil error: %s*" label) + (concat output "\n"))))))))))))) + +(defun fossil-ui--commit-with-message (message paths) + "Commit PATHS with MESSAGE from the current Fossil dashboard." + (when (string-empty-p (string-trim message)) + (user-error "Commit message cannot be empty")) + (fossil-ui--async + "commit" + (append (list "commit" "--hash" "--no-prompt" "--comment" message "--") paths) + (lambda (_) + (when (buffer-live-p (current-buffer)) + (textui-set-state (current-buffer) :selected nil))))) + +(defun fossil-ui-commit (&optional edit) + "Commit selected files; with prefix EDIT, use a multiline buffer." + (interactive "P") + (let ((paths (copy-sequence (plist-get textui-state :selected)))) + (unless paths + (user-error "Select files with SPC before committing")) + (if edit + (fossil-ui--open-commit-buffer paths) + (let ((message (read-string "Commit message: " nil + 'fossil-ui--commit-history))) + (fossil-ui--commit-with-message message paths))))) + +(defvar fossil-ui-commit-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map text-mode-map) + (define-key map (kbd "C-c C-c") #'fossil-ui-commit-submit) + (define-key map (kbd "C-c C-k") #'fossil-ui-commit-cancel) + map)) + +(define-derived-mode fossil-ui-commit-mode text-mode "Fossil-Commit" + "Major mode for composing a Fossil check-in comment." + (setq-local header-line-format + "Write a check-in comment · C-c C-c commit · C-c C-k cancel")) + +(defun fossil-ui--open-commit-buffer (paths) + "Open a multiline commit buffer for PATHS." + (let ((owner (current-buffer)) + (buffer (get-buffer-create + (format "*fossil commit: %s*" + (file-name-nondirectory + (directory-file-name (plist-get textui-state :root))))))) + (with-current-buffer buffer + (fossil-ui-commit-mode) + (setq-local fossil-ui--commit-owner owner + fossil-ui--commit-paths paths) + (erase-buffer)) + (pop-to-buffer buffer))) + +(defun fossil-ui-commit-submit () + "Submit the current multiline Fossil commit message." + (interactive) + (let ((message (string-trim-right (buffer-substring-no-properties + (point-min) (point-max)))) + (owner fossil-ui--commit-owner) + (paths fossil-ui--commit-paths) + (buffer (current-buffer))) + (unless (buffer-live-p owner) + (user-error "The Fossil dashboard was closed")) + (when (string-empty-p (string-trim message)) + (user-error "Commit message cannot be empty")) + (kill-buffer buffer) + (pop-to-buffer owner) + (with-current-buffer owner + (fossil-ui--commit-with-message message paths)))) + +(defun fossil-ui-commit-cancel () + "Cancel the current multiline Fossil commit." + (interactive) + (let ((owner fossil-ui--commit-owner)) + (kill-buffer (current-buffer)) + (when (buffer-live-p owner) (pop-to-buffer owner)) + (message "Commit cancelled"))) + +(defun fossil-ui-update () + "Update the current Fossil branch." + (interactive) + (fossil-ui--async "update" '("update"))) + +(defun fossil-ui-sync () + "Synchronize the current Fossil repository." + (interactive) + (unless (plist-get textui-state :remote) + (user-error "This repository has no configured remote")) + (fossil-ui--async "sync" '("sync"))) + +(defun fossil-ui-switch-branch () + "Update the checkout to an existing branch." + (interactive) + (let* ((branches (or (plist-get textui-state :branches) + (user-error "No branches found"))) + (current (plist-get textui-state :branch)) + (branch (completing-read "Update to branch: " branches nil t nil nil current))) + (unless (string= branch current) + (when (or (null (plist-get textui-state :changes)) + (yes-or-no-p + (format "Update to %s and merge your local changes into it? " branch))) + (fossil-ui--async (format "update %s" branch) (list "update" branch)))))) + +(defun fossil-ui-help () + "Show the compact Fossil UI key reference." + (interactive) + (fossil-ui--show-output + "*fossil-ui help*" + (concat + "Fossil UI\n\n" + "There is no staging area. [x] only means that the file will be passed\n" + "to the next commit from this buffer. Fossil itself is unchanged.\n\n" + "SPC toggle commit selection A / X select all / none\n" + "RET show file diff o visit file\n" + "a add an unversioned file f stop tracking file\n" + "r revert selected/current U preview and run undo\n" + "c commit selected files C-u c multiline comment\n" + "u / s update / sync b switch branch\n" + "g refresh j/k,n/p move between files\n" + "q close\n\n" + "In a diff: [c and ]c move between hunks; TAB folds a hunk.\n"))) + +(defun fossil-ui--card-range () + "Return only the current changed-file widget span for hl-line." + (if-let* ((path (fossil-ui--path-at-point)) + (match (save-excursion + (goto-char (line-beginning-position)) + (text-property-search-forward + 'fossil-ui-path path #'equal)))) + (cons (prop-match-beginning match) (prop-match-end match)) + (cons (point) (point)))) + +(defun fossil-ui--visible-height () + "Return the smallest body height displaying the current buffer." + (let ((windows (get-buffer-window-list (current-buffer) nil t))) + (when windows + (apply #'min (mapcar #'window-body-height windows))))) + +(defun fossil-ui--window-size-changed (_window) + "Refresh timeline density when this dashboard's window height changes." + (when (and (derived-mode-p 'fossil-ui-mode) + (not (bound-and-true-p textui--refreshing))) + (when-let* ((height (fossil-ui--visible-height))) + (unless (equal height fossil-ui--window-height) + (let ((path (fossil-ui--path-at-point))) + (setq fossil-ui--window-height height) + (textui-set-state (current-buffer) :height height) + (when path (fossil-ui--goto-path path))))))) + +(defvar fossil-ui-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map textui-mode-map) + (define-key map (kbd "SPC") #'fossil-ui-toggle-mark) + (define-key map (kbd "A") #'fossil-ui-mark-all) + (define-key map (kbd "X") #'fossil-ui-unmark-all) + (define-key map (kbd "RET") #'fossil-ui-diff) + (define-key map (kbd "") #'fossil-ui-diff) + (define-key map (kbd "o") #'fossil-ui-visit-file) + (define-key map (kbd "a") #'fossil-ui-add) + (define-key map (kbd "f") #'fossil-ui-forget) + (define-key map (kbd "r") #'fossil-ui-revert) + (define-key map (kbd "U") #'fossil-ui-undo) + (define-key map (kbd "c") #'fossil-ui-commit) + (define-key map (kbd "u") #'fossil-ui-update) + (define-key map (kbd "s") #'fossil-ui-sync) + (define-key map (kbd "b") #'fossil-ui-switch-branch) + (define-key map (kbd "g") #'fossil-ui-refresh) + (define-key map (kbd "?") #'fossil-ui-help) + (define-key map (kbd "j") #'fossil-ui-next-file) + (define-key map (kbd "n") #'fossil-ui-next-file) + (define-key map (kbd "k") #'fossil-ui-previous-file) + (define-key map (kbd "p") #'fossil-ui-previous-file) + (define-key map (kbd "q") #'quit-window) + map)) + +(define-derived-mode fossil-ui-mode textui-mode "Fossil" + "Major mode for the compact Fossil dashboard." + (setq-local truncate-lines t + cursor-type nil + mode-line-format "" + hl-line-range-function #'fossil-ui--card-range) + (face-remap-set-base 'hl-line 'fossil-ui-selected) + (hl-line-mode 1) + (add-hook 'window-size-change-functions #'fossil-ui--window-size-changed nil t) + (when (fboundp 'general-define-key) + (fossil-ui--install-general-local-bindings)) + (when (fboundp 'evil-normalize-keymaps) + (evil-normalize-keymaps))) + +(defconst fossil-ui--evil-bindings + '(("SPC" . fossil-ui-toggle-mark) + ("A" . fossil-ui-mark-all) + ("X" . fossil-ui-unmark-all) + ("RET" . fossil-ui-diff) + ("" . fossil-ui-diff) + ("o" . fossil-ui-visit-file) + ("a" . fossil-ui-add) + ("f" . fossil-ui-forget) + ("r" . fossil-ui-revert) + ("U" . fossil-ui-undo) + ("c" . fossil-ui-commit) + ("u" . fossil-ui-update) + ("s" . fossil-ui-sync) + ("b" . fossil-ui-switch-branch) + ("g" . fossil-ui-refresh) + ("?" . fossil-ui-help) + ("j" . fossil-ui-next-file) + ("n" . fossil-ui-next-file) + ("k" . fossil-ui-previous-file) + ("p" . fossil-ui-previous-file) + ("q" . quit-window)) + "Bindings which the Fossil dashboard owns in modal states.") + +(defun fossil-ui--install-general-local-bindings () + "Install buffer-local General overrides for the Fossil dashboard." + (fossil-ui--install-general-local-map fossil-ui--evil-bindings)) + +(defun fossil-ui--install-general-local-map (bindings) + "Install buffer-local General overrides from BINDINGS." + (general-local-map) + (dolist (binding bindings) + (general-define-key + :states '(normal motion) + :keymaps 'general-override-local-mode-map + (car binding) (cdr binding))) + ;; General marks its global override auxiliaries as Evil intercept maps, but + ;; not its buffer-local override auxiliaries. Promote the latter as well so + ;; the local dashboard bindings precede General's global ones. + (when (fboundp 'evil-get-auxiliary-keymap) + (dolist (state '(normal motion)) + (evil-make-intercept-map + (evil-get-auxiliary-keymap general-override-local-mode-map + state t t) + state)))) + +(defun fossil-ui--install-evil-bindings () + "Make the Fossil map win over global Evil and General maps." + (evil-set-initial-state 'fossil-ui-mode 'normal) + (evil-set-initial-state 'fossil-ui-diff-mode 'normal) + ;; An intercept map is deliberately used here. A regular major-mode map is + ;; consulted after Evil's normal-state maps, where keys such as `g' and SPC + ;; are prefixes. The dashboard must own its complete one-key vocabulary. + (evil-make-intercept-map fossil-ui-mode-map) + (dolist (binding fossil-ui--evil-bindings) + (evil-define-key* '(normal motion) fossil-ui-mode-map + (kbd (car binding)) (cdr binding))) + (evil-make-intercept-map fossil-ui-diff-mode-map) + (dolist (binding fossil-ui--diff-evil-bindings) + (evil-define-key* '(normal motion) fossil-ui-diff-mode-map + (kbd (car binding)) (cdr binding))) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (derived-mode-p 'fossil-ui-mode 'fossil-ui-diff-mode) + (evil-normalize-keymaps))))) + +(with-eval-after-load 'evil + (fossil-ui--install-evil-bindings)) + +(with-eval-after-load 'general + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (derived-mode-p 'fossil-ui-mode 'fossil-ui-diff-mode) + (fossil-ui--install-general-local-map + (if (derived-mode-p 'fossil-ui-diff-mode) + fossil-ui--diff-evil-bindings + fossil-ui--evil-bindings)) + (when (fboundp 'evil-normalize-keymaps) + (evil-normalize-keymaps)))))) + +;;;###autoload +(defun fossil-ui-status (&optional directory) + "Open a Fossil dashboard for DIRECTORY or the current checkout." + (interactive) + (let* ((start (fossil-ui--input-directory directory)) + (snapshot (fossil-ui--snapshot start)) + (root (plist-get snapshot :root)) + (name (format "*fossil: %s*" + (file-name-nondirectory (directory-file-name root)))) + (existing (get-buffer name))) + (when (and existing + (with-current-buffer existing + (not (derived-mode-p 'fossil-ui-mode)))) + (user-error "A non-Fossil buffer already uses %s" name)) + (let ((buffer (or existing (get-buffer-create name)))) + (with-current-buffer buffer + (unless (derived-mode-p 'fossil-ui-mode) + (fossil-ui-mode)) + (setq-local default-directory root)) + (textui-open name #'fossil-ui--frame snapshot) + (with-current-buffer buffer + (when-let* ((height (fossil-ui--visible-height))) + (setq fossil-ui--window-height height) + (textui-set-state buffer :height height)) + (fossil-ui-next-file)) + buffer))) + +;;;###autoload +(defalias 'fossil-ui #'fossil-ui-status) + +(provide 'fossil-ui) +;;; fossil-ui.el ends here diff --git a/lisp/himalaya-client.el b/lisp/himalaya-client.el new file mode 100644 index 0000000..871ec50 --- /dev/null +++ b/lisp/himalaya-client.el @@ -0,0 +1,461 @@ +;;; himalaya-client.el --- Asynchronous Himalaya client -*- lexical-binding: t; -*- + +(require 'json) +(require 'message) +(require 'mml) +(require 'subr-x) + +(defgroup himalaya-client nil + "Himalaya mail client." + :group 'mail) + +(defcustom himalaya-client-program "himalaya" + "Himalaya executable." + :type 'string + :group 'himalaya-client) + +(defcustom himalaya-client-page-size 30 + "Number of envelopes requested per page." + :type 'integer + :group 'himalaya-client) + +(defcustom himalaya-client-download-directory (expand-file-name "Downloads" "~") + "Directory used for downloaded attachments." + :type 'directory + :group 'himalaya-client) + +(defcustom himalaya-client-drafts-folder "Drafts" + "Folder used for saved drafts." + :type 'string + :group 'himalaya-client) + +(defun himalaya-client--concise-error (text fallback) + (let ((message (string-trim + (replace-regexp-in-string "[[:space:]\n\r]+" " " (or text ""))))) + (if (string-empty-p message) + fallback + (truncate-string-to-width message 300 nil nil "…")))) + +(defun himalaya-client--process-result (process stdout stderr callback plain-output) + (unless (process-get process 'himalaya-client-finished) + (process-put process 'himalaya-client-finished t) + (let ((status (process-exit-status process)) + (output (with-current-buffer stdout (buffer-string))) + (error-output (with-current-buffer stderr (buffer-string)))) + (kill-buffer stdout) + (kill-buffer stderr) + (cond + ((not (zerop status)) + (funcall callback nil + (himalaya-client--concise-error + (if (string-empty-p (string-trim error-output)) output error-output) + (format "Himalaya exited with status %d" status)))) + ((not (string-empty-p error-output)) + (funcall callback nil + (himalaya-client--concise-error + error-output + "Himalaya wrote to stderr"))) + (plain-output + (funcall callback output nil)) + (t + (let (result parse-error) + (condition-case error + (setq result + (unless (string-empty-p (string-trim output)) + (json-parse-string output + :object-type 'plist + :array-type 'list + :null-object nil + :false-object nil))) + (error + (setq parse-error + (format "Invalid Himalaya JSON: %s" + (error-message-string error))))) + (if parse-error + (funcall callback nil parse-error) + (funcall callback result nil)))))))) + +(defun himalaya-client-request (arguments callback &optional input plain-output) + "Run Himalaya with ARGUMENTS and call CALLBACK with result and error." + (let ((stdout (generate-new-buffer " *himalaya-client-out*")) + (stderr (generate-new-buffer " *himalaya-client-err*")) + process) + (condition-case error + (progn + (setq process + (make-process + :name "himalaya-client" + :buffer stdout + :stderr stderr + :command (append (list himalaya-client-program "--quiet" "--output" + (if plain-output "plain" "json")) + arguments) + :connection-type 'pipe + :coding '(utf-8-unix . utf-8-unix) + :noquery t + :sentinel + (lambda (finished-process _event) + (when (memq (process-status finished-process) '(exit signal)) + (himalaya-client--process-result + finished-process stdout stderr callback plain-output))))) + (when (process-live-p process) + (when input + (process-send-string process input)) + (process-send-eof process)) + process) + (error + (when process + (process-put process 'himalaya-client-finished t)) + (kill-buffer stdout) + (kill-buffer stderr) + (funcall callback nil (error-message-string error)) + nil)))) + +(defun himalaya-client--value (object key) + (let ((name (substring (symbol-name key) 1))) + (cond + ((hash-table-p object) + (or (gethash key object) + (gethash (intern name) object) + (gethash name object))) + ((and (listp object) (keywordp (car object))) + (plist-get object key)) + ((listp object) + (or (alist-get key object) + (alist-get (intern name) object) + (alist-get name object nil nil #'equal)))))) + +(defun himalaya-client--flag-name (flag) + (when (or (stringp flag) (symbolp flag)) + (let ((name (replace-regexp-in-string + "\\`[:\\\\]+" "" (if (symbolp flag) (symbol-name flag) flag)))) + (unless (string-empty-p name) + (downcase name))))) + +(defun himalaya-client--flag-names (flags) + (cond + ((null flags) nil) + ((or (stringp flags) (symbolp flags)) + (let ((name (himalaya-client--flag-name flags))) + (and name (list name)))) + ((vectorp flags) + (himalaya-client--flag-names (append flags nil))) + ((hash-table-p flags) + (let ((name (or (gethash :name flags) + (gethash 'name flags) + (gethash "name" flags))) + names) + (if name + (himalaya-client--flag-names name) + (maphash + (lambda (key value) + (when value + (setq names (append names (himalaya-client--flag-names key))))) + flags) + names))) + ((and (listp flags) (keywordp (car flags))) + (let ((name (plist-get flags :name)) + names) + (if name + (himalaya-client--flag-names name) + (while flags + (when (cadr flags) + (setq names + (append names (himalaya-client--flag-names (car flags))))) + (setq flags (cddr flags))) + names))) + ((listp flags) + (let (names) + (dolist (flag flags names) + (setq names (append names (himalaya-client--flag-names flag)))))))) + +(defun himalaya-client--address-value (address key alternate) + (or (himalaya-client--value address key) + (himalaya-client--value address alternate))) + +(defun himalaya-client--normalize-envelope (envelope) + (let* ((from (himalaya-client--value envelope :from)) + (to (himalaya-client--value envelope :to)) + (flags (delete-dups + (himalaya-client--flag-names + (himalaya-client--value envelope :flags)))) + (id (himalaya-client--value envelope :id))) + (list :id (and id (format "%s" id)) + :subject (or (himalaya-client--value envelope :subject) "") + :from-name (or (himalaya-client--address-value from :name :display-name) "") + :from-address (or (himalaya-client--address-value from :addr :address) "") + :to-name (or (himalaya-client--address-value to :name :display-name) "") + :to-address (or (himalaya-client--address-value to :addr :address) "") + :date (or (himalaya-client--value envelope :date) "") + :flags flags + :unread (not (member "seen" flags)) + :starred (and (member "flagged" flags) t) + :deleted (and (member "deleted" flags) t) + :draft (and (member "draft" flags) t) + :answered (and (member "answered" flags) t) + :has-attachment + (and (or (himalaya-client--value envelope :has_attachment) + (himalaya-client--value envelope :has-attachment)) + t)))) + +(defun himalaya-client--as-list (value) + (cond + ((null value) nil) + ((vectorp value) (append value nil)) + ((listp value) value) + (t (list value)))) + +(defun himalaya-client--strings (values) + (mapcar (lambda (value) (format "%s" value)) + (himalaya-client--as-list values))) + +(defun himalaya-client--query-string (value) + (cond + ((null value) nil) + ((stringp value) (unless (string-empty-p (string-trim value)) value)) + ((listp value) (string-join (himalaya-client--strings value) " ")) + (t (format "%s" value)))) + +(defun himalaya-client--envelope-query (query sort) + (let ((filter (himalaya-client--query-string query)) + (ordering (himalaya-client--query-string sort))) + (when (and ordering + (not (string-match-p "\\`[[:space:]]*order[[:space:]]+by\\_>" ordering))) + (setq ordering (concat "order by " ordering))) + (string-join (delq nil (list filter ordering)) " "))) + +(defun himalaya-client-accounts (callback) + "Fetch configured accounts and call CALLBACK." + (himalaya-client-request '("account" "list") callback)) + +(defun himalaya-client-folders (account callback) + "Fetch folders for ACCOUNT and call CALLBACK." + (himalaya-client-request + (list "folder" "list" "--account" account) + callback)) + +(defun himalaya-client-envelopes (account folder page query sort callback) + "Fetch one envelope page and call CALLBACK with normalized envelopes." + (let ((arguments + (list "envelope" "list" + "--account" account + "--folder" folder + "--page" (number-to-string (or page 1)) + "--page-size" (number-to-string himalaya-client-page-size))) + (search (himalaya-client--envelope-query query sort))) + (when (not (string-empty-p search)) + (setq arguments (append arguments (list search)))) + (himalaya-client-request + arguments + (lambda (result error) + (if error + (funcall callback nil error) + (funcall callback + (mapcar #'himalaya-client--normalize-envelope result) + nil)))))) + +(defun himalaya-client-read (account folder id callback) + "Preview message ID in FOLDER for ACCOUNT and call CALLBACK." + (himalaya-client-request + (list "message" "read" "--account" account "--folder" folder "--preview" + (format "%s" id)) + callback)) + +(defun himalaya-client-thread (account folder id callback) + "Preview the thread containing ID and call CALLBACK." + (himalaya-client-request + (list "message" "thread" "--account" account "--folder" folder "--preview" + (format "%s" id)) + callback)) + +(defun himalaya-client--operation-name (operation allowed) + (let ((name (downcase (format "%s" operation)))) + (unless (member name allowed) + (error "Unsupported Himalaya operation: %s" operation)) + name)) + +(defun himalaya-client-flag (account folder operation ids flags callback) + "Apply flag OPERATION to IDS in FOLDER and call CALLBACK." + (let ((name (himalaya-client--operation-name operation '("add" "set" "remove")))) + (himalaya-client-request + (append (list "flag" name "--account" account "--folder" folder) + (himalaya-client--strings ids) + (himalaya-client--strings flags)) + callback))) + +(defun himalaya-client-transfer (account folder operation target ids callback) + "Apply transfer OPERATION to IDS and call CALLBACK." + (let ((name (himalaya-client--operation-name operation '("copy" "move")))) + (himalaya-client-request + (append (list "message" name "--account" account "--folder" folder target) + (himalaya-client--strings ids)) + callback))) + +(defun himalaya-client-delete (account folder ids callback) + "Mark IDS deleted in FOLDER and call CALLBACK." + (himalaya-client-flag account folder "add" ids '("deleted") callback)) + +(defun himalaya-client-expunge (account folder callback) + "Expunge deleted messages from FOLDER and call CALLBACK." + (himalaya-client-request + (list "folder" "expunge" "--account" account folder) + callback)) + +(defun himalaya-client-download (account folder ids callback) + "Download attachments from IDS and call CALLBACK." + (himalaya-client-request + (append (list "attachment" "download" + "--account" account + "--folder" folder + "--downloads-dir" + (expand-file-name himalaya-client-download-directory)) + (himalaya-client--strings ids)) + callback)) + +(defvar-local himalaya-client-compose-account nil) +(defvar-local himalaya-client-compose-pending nil) + +(define-derived-mode himalaya-client-compose-mode message-mode "Himalaya Compose" + "Edit a Himalaya MML message.") + +(defun himalaya-client--compose-contents () + (buffer-substring-no-properties (point-min) (point-max))) + +(defun himalaya-client--compose-mime () + (let ((contents (himalaya-client--compose-contents)) + (directory default-directory) + (options message-options) + (separator mail-header-separator)) + (with-temp-buffer + (let ((default-directory directory) + (message-options options) + (mail-header-separator separator) + (message-inhibit-body-encoding nil)) + (insert contents) + (mml-to-mime) + (buffer-string))))) + +(defun himalaya-client--finish-compose (buffer action result error) + (if error + (progn + (when (buffer-live-p buffer) + (with-current-buffer buffer + (setq himalaya-client-compose-pending nil))) + (message "Himalaya could not %s message: %s" action error)) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (set-buffer-modified-p nil)) + (kill-buffer buffer)) + (message "Himalaya message %s%s" + (if (string= action "send") "sent" "saved to drafts") + (if (and (stringp result) (not (string-empty-p (string-trim result)))) + (format ": %s" (string-trim result)) + "")))) + +(defun himalaya-client-compose-send () + "Send the current Himalaya MML message." + (interactive) + (unless (derived-mode-p 'himalaya-client-compose-mode) + (user-error "Not in a Himalaya compose buffer")) + (when himalaya-client-compose-pending + (user-error "A Himalaya compose operation is already running")) + (let ((buffer (current-buffer)) + (account himalaya-client-compose-account) + (contents (himalaya-client--compose-contents))) + (setq himalaya-client-compose-pending t) + (himalaya-client-request + (list "template" "send" "--account" account) + (lambda (result error) + (himalaya-client--finish-compose buffer "send" result error)) + contents))) + +(defun himalaya-client-compose-save-draft () + "Save the current compose buffer to the drafts folder." + (interactive) + (unless (derived-mode-p 'himalaya-client-compose-mode) + (user-error "Not in a Himalaya compose buffer")) + (when himalaya-client-compose-pending + (user-error "A Himalaya compose operation is already running")) + (let ((buffer (current-buffer)) + (account himalaya-client-compose-account) + (mime (himalaya-client--compose-mime))) + (setq himalaya-client-compose-pending t) + (himalaya-client-request + (list "message" "save" + "--account" account + "--folder" himalaya-client-drafts-folder) + (lambda (result error) + (himalaya-client--finish-compose buffer "save" result error)) + mime + t))) + +(define-key himalaya-client-compose-mode-map (kbd "C-c C-c") + #'himalaya-client-compose-send) +(define-key himalaya-client-compose-mode-map (kbd "C-c C-d") + #'himalaya-client-compose-save-draft) +(define-key himalaya-client-compose-mode-map (kbd "C-c C-a") + #'mml-attach-file) + +(defun himalaya-client--template-arguments (account folder id kind) + (let ((name (if kind (downcase (format "%s" kind)) "new"))) + (unless (member name '("new" "reply" "reply-all" "forward")) + (user-error "Unsupported compose kind: %s" kind)) + (when (and (not (string= name "new")) (or (null folder) (null id))) + (user-error "Compose kind %s requires a folder and message ID" name)) + (cond + ((string= name "new") + (list "template" "write" "--account" account)) + ((string= name "reply") + (list "template" "reply" "--account" account "--folder" folder + (format "%s" id))) + ((string= name "reply-all") + (list "template" "reply" "--account" account "--folder" folder "--all" + (format "%s" id))) + (t + (list "template" "forward" "--account" account "--folder" folder + (format "%s" id)))))) + +(defun himalaya-client--place-template-cursor (cursor) + (let ((row (or (himalaya-client--value cursor :row) 1)) + (column (or (himalaya-client--value cursor :col) 0))) + (goto-char (point-min)) + (forward-line (max 0 (1- row))) + (move-to-column column))) + +(defun himalaya-client--open-compose-buffer (account template) + (let ((content (if (stringp template) + template + (himalaya-client--value template :content))) + (cursor (and (listp template) + (himalaya-client--value template :cursor))) + (buffer (generate-new-buffer "*Himalaya compose*"))) + (unless (stringp content) + (kill-buffer buffer) + (error "Himalaya returned an invalid message template")) + (with-current-buffer buffer + (himalaya-client-compose-mode) + (setq himalaya-client-compose-account account) + (insert content) + (if cursor + (himalaya-client--place-template-cursor cursor) + (goto-char (point-max)))) + (pop-to-buffer buffer))) + +(defun himalaya-client-compose (account &optional folder id kind) + "Open an asynchronous compose buffer for ACCOUNT." + (interactive "sAccount: ") + (let ((arguments (himalaya-client--template-arguments account folder id kind))) + (himalaya-client-request + arguments + (lambda (template error) + (if error + (message "Himalaya could not compose message: %s" error) + (condition-case compose-error + (himalaya-client--open-compose-buffer account template) + (error + (message "Himalaya could not compose message: %s" + (error-message-string compose-error))))))))) + +(provide 'himalaya-client) + +;;; himalaya-client.el ends here diff --git a/lisp/himalaya-ui.el b/lisp/himalaya-ui.el new file mode 100644 index 0000000..cbcca9a --- /dev/null +++ b/lisp/himalaya-ui.el @@ -0,0 +1,1128 @@ +;;; himalaya-ui.el --- Keyboard-first VUI for Himalaya -*- lexical-binding: t; -*- + +(require 'cl-lib) +(require 'seq) +(require 'subr-x) +(require 'himalaya-client) +(require 'vui) +(require 'vui-components) + +(declare-function evil-define-key* "evil-core" (state keymap key def &rest bindings)) +(declare-function evil-set-initial-state "evil-core" (mode state)) + +(defvar-local himalaya-ui--dispatch nil) +(defvar-local himalaya-ui--visible-ids nil) +(defvar-local himalaya-ui--folders nil) +(defvar-local himalaya-ui--marked nil) +(defvar-local himalaya-ui--view 'mailbox) +(defvar-local himalaya-ui--message-id nil) +(defvar-local himalaya-ui--folders-request-generation 0) +(defvar-local himalaya-ui--folders-request nil) +(defvar-local himalaya-ui--envelopes-request-generation 0) +(defvar-local himalaya-ui--envelopes-request nil) +(defvar-local himalaya-ui--preview-request-generation 0) +(defvar-local himalaya-ui--preview-request nil) +(defvar-local himalaya-ui--mutation-generation 0) + +(defun himalaya-ui--value (object key) + (cond + ((hash-table-p object) + (or (gethash key object) + (gethash (substring (symbol-name key) 1) object))) + ((and (listp object) (keywordp (car object))) + (plist-get object key)) + ((listp object) + (or (alist-get key object) + (alist-get (substring (symbol-name key) 1) object nil nil #'equal))))) + +(defun himalaya-ui--items (result key) + (let ((items (or (himalaya-ui--value result key) result))) + (cond + ((vectorp items) (append items nil)) + ((null items) nil) + ((and (listp items) (keywordp (car items))) (list items)) + ((listp items) items) + (t (list items))))) + +(defun himalaya-ui--names (result key) + (delete-dups + (delq nil + (mapcar + (lambda (item) + (let ((name (if (stringp item) + item + (or (himalaya-ui--value item :name) + (himalaya-ui--value item :account) + (himalaya-ui--value item :folder) + (himalaya-ui--value item :id))))) + (when name (format "%s" name)))) + (himalaya-ui--items result key))))) + +(defun himalaya-ui--fit (value width) + (let ((text (if value (format "%s" value) ""))) + (if (> (string-width text) width) + (truncate-string-to-width text width nil nil "…") + text))) + +(defun himalaya-ui--sender (envelope) + (let ((name (plist-get envelope :from-name)) + (address (plist-get envelope :from-address))) + (cond + ((not (string-empty-p (or name ""))) name) + ((not (string-empty-p (or address ""))) address) + (t "Unknown sender")))) + +(defun himalaya-ui--recipient (envelope) + (let ((name (plist-get envelope :to-name)) + (address (plist-get envelope :to-address))) + (cond + ((not (string-empty-p (or name ""))) name) + ((not (string-empty-p (or address ""))) address) + (t "Unknown recipient")))) + +(defun himalaya-ui--subject (envelope) + (or (plist-get envelope :subject) "(no subject)")) + +(defun himalaya-ui--subject-face (envelope) + (cond + ((plist-get envelope :deleted) 'error) + ((plist-get envelope :unread) 'outline-2) + (t 'shadow))) + +(defun himalaya-ui--indicators (envelope marked) + (format "%s%s%s%s" + (if (member (plist-get envelope :id) marked) "+" " ") + (if (plist-get envelope :unread) "N" " ") + (if (plist-get envelope :starred) "*" " ") + (if (plist-get envelope :has-attachment) "@" " "))) + +(defun himalaya-ui--envelope (id envelopes) + (seq-find (lambda (envelope) + (equal (plist-get envelope :id) id)) + envelopes)) + +(defun himalaya-ui--split-width (text width) + (let ((start 0) + (index 0) + (column 0) + (pieces nil)) + (while (< index (length text)) + (let ((next (+ column (max 1 (or (char-width (aref text index)) 1))))) + (when (and (> next width) (> index start)) + (push (substring text start index) pieces) + (setq start index + column 0 + next (max 1 (or (char-width (aref text index)) 1)))) + (setq column next + index (1+ index)))) + (when (< start (length text)) + (push (substring text start) pieces)) + (nreverse (or pieces (list ""))))) + +(defun himalaya-ui--wrap-line (line width) + (if (string-empty-p line) + (list "") + (let ((current "") + (current-width 0) + (lines nil)) + (dolist (word (split-string line nil t)) + (dolist (piece (himalaya-ui--split-width word width)) + (let ((piece-width (string-width piece))) + (if (and (not (string-empty-p current)) + (> (+ current-width 1 piece-width) width)) + (progn + (push current lines) + (setq current piece + current-width piece-width)) + (setq current (if (string-empty-p current) + piece + (concat current " " piece)) + current-width (if (zerop current-width) + piece-width + (+ current-width 1 piece-width))))))) + (unless (string-empty-p current) + (push current lines)) + (nreverse (or lines (list "")))))) + +(defun himalaya-ui--wrap-body (body width) + (mapcan (lambda (line) + (himalaya-ui--wrap-line line width)) + (split-string (or body "") "\n" nil))) + +(defun himalaya-ui--body-text (result) + (cond + ((stringp result) result) + ((vectorp result) + (mapconcat #'himalaya-ui--body-text (append result nil) "\n\n")) + ((and (listp result) (not (keywordp (car result)))) + (mapconcat #'himalaya-ui--body-text result "\n\n")) + (t + (let ((body (or (himalaya-ui--value result :body) + (himalaya-ui--value result :content) + (himalaya-ui--value result :text) + (himalaya-ui--value result :message) + (himalaya-ui--value result :preview)))) + (if body + (himalaya-ui--body-text body) + (format "%s" result)))))) + +(defun himalaya-ui--last-sync (last-sync) + (if last-sync + (format-time-string "%H:%M" (seconds-to-time last-sync)) + "never")) + +(defun himalaya-ui--quiet-button (label face callback &optional key) + (vui-button label + :on-click callback + :no-decoration t + :face face + :help-echo nil + :key key)) + +(defun himalaya-ui--wide-messages (envelopes marked open-message width) + (let* ((sender-width 22) + (date-width 16) + (status-width 4) + (separator-width 3) + (subject-width + (max 20 (- width sender-width date-width status-width separator-width)))) + (vui-table + :columns `((:header "" :width ,status-width :grow t :truncate t :align :left) + (:header "From" :width ,sender-width :grow t :truncate t :align :left) + (:header "Date" :width ,date-width :grow t :truncate t :align :left) + (:header "Subject" :width ,subject-width :grow t :truncate t :align :left)) + :rows + (mapcar + (lambda (envelope) + (let ((id (plist-get envelope :id))) + (list + (vui-text (himalaya-ui--fit (himalaya-ui--indicators envelope marked) + status-width) + :face (if (member id marked) 'success 'shadow)) + (vui-text (himalaya-ui--fit (himalaya-ui--sender envelope) sender-width) + :face (if (plist-get envelope :unread) 'outline-3 'shadow)) + (vui-text (himalaya-ui--fit (plist-get envelope :date) date-width) + :face 'shadow) + (himalaya-ui--quiet-button + (himalaya-ui--fit (himalaya-ui--subject envelope) subject-width) + (himalaya-ui--subject-face envelope) + (lambda () (funcall open-message id)) + id)))) + envelopes) + :border nil + :header-face 'outline-3 + :border-face 'shadow))) + +(defun himalaya-ui--compact-messages (envelopes marked open-message width) + (vui-list + envelopes + (lambda (envelope) + (let* ((id (plist-get envelope :id)) + (label-width (max 12 (- width 5))) + (meta-width (max 12 (- width 6)))) + (vui-vstack + :spacing 0 + (himalaya-ui--quiet-button + (format "%s %s" + (himalaya-ui--indicators envelope marked) + (himalaya-ui--fit (himalaya-ui--subject envelope) label-width)) + (himalaya-ui--subject-face envelope) + (lambda () (funcall open-message id)) + id) + (vui-text + (format " %s" + (himalaya-ui--fit + (format "%s · %s" + (himalaya-ui--sender envelope) + (or (plist-get envelope :date) "")) + meta-width)) + :face 'shadow)))) + (lambda (envelope) (plist-get envelope :id)))) + +(defun himalaya-ui--empty-state (folder query width) + (let ((text (cond + ((not (string-empty-p query)) "No messages match this search") + ((and folder (string-equal-ignore-case folder "INBOX")) "Inbox zero") + (t (format "%s is empty" (or folder "Folder")))))) + (vui-vstack + :spacing 1 + (vui-box (vui-text "—" :face 'shadow) :width width :align :center) + (vui-box (vui-text text :face 'shadow) :width width :align :center)))) + +(defun himalaya-ui--header (account folder unread loading refreshing last-sync width) + (vui-flex + :width width + :justify :space-between + (vui-hstack + :spacing 1 + (vui-text "HIMALAYA" :face 'outline-1) + (vui-text "/" :face 'shadow) + (vui-text (himalaya-ui--fit (or account "no account") 20) :face 'outline-2) + (vui-text "/" :face 'shadow) + (vui-text (himalaya-ui--fit (or folder "no folder") 24) :face 'outline-3)) + (vui-text + (cond + (loading "loading") + (refreshing (format "%d unread · syncing" unread)) + (t (format "%d unread · synced %s" unread + (himalaya-ui--last-sync last-sync)))) + :face (cond (loading 'warning) (refreshing 'warning) (t 'success))))) + +(defun himalaya-ui--folder-navigation (accounts account folders folder select-account select-folder refresh search clear compose) + (vui-vstack + :spacing 0 + (vui-hstack + :spacing 1 + (vui-text "Accounts" :face 'shadow) + (vui-list + accounts + (lambda (name) + (himalaya-ui--quiet-button + (himalaya-ui--fit name 16) + (if (equal name account) 'outline-2 'link) + (lambda () (funcall select-account name)))) + #'identity + :vertical nil + :spacing 2)) + (vui-hstack + :spacing 1 + (vui-text "Folders " :face 'shadow) + (vui-list + folders + (lambda (name) + (himalaya-ui--quiet-button + (himalaya-ui--fit name 18) + (if (equal name folder) 'outline-3 'link) + (lambda () (funcall select-folder name)))) + #'identity + :vertical nil + :spacing 2)) + (vui-hstack + :spacing 2 + (himalaya-ui--quiet-button "refresh" 'link refresh) + (himalaya-ui--quiet-button "search" 'link search) + (himalaya-ui--quiet-button "clear" 'link clear) + (himalaya-ui--quiet-button "new message" 'link compose)))) + +(defun himalaya-ui--reader (view account folder envelope body loading error width) + (let* ((subject (if envelope (himalaya-ui--subject envelope) "Message")) + (body-width (max 24 (- width 4))) + (kind (if (eq view 'thread) "thread preview" "message preview"))) + (vui-vstack + :spacing 1 + (vui-flex + :width width + :justify :space-between + (vui-hstack + :spacing 0 + (vui-text "mail" :face 'shadow) + (vui-text " / " :face 'shadow) + (vui-text (himalaya-ui--fit account 18) :face 'link) + (vui-text " / " :face 'shadow) + (vui-text (himalaya-ui--fit folder 20) :face 'link) + (vui-text " / " :face 'shadow) + (vui-text (if (eq view 'thread) "thread" "message") :face 'outline-3)) + (vui-text kind :face 'shadow)) + (vui-box + (vui-text (himalaya-ui--fit subject (max 20 (- width 4))) :face 'outline-1) + :width width + :align :center) + (vui-flex + :width width + :justify :space-between + (vui-text (if envelope + (format "%s <%s>" + (himalaya-ui--fit (himalaya-ui--sender envelope) 28) + (himalaya-ui--fit (plist-get envelope :from-address) 32)) + "Unknown sender") + :face 'outline-2) + (vui-text (himalaya-ui--fit (and envelope (plist-get envelope :date)) 28) + :face 'shadow)) + (when envelope + (vui-collapsible + :title "Details" + :title-face 'link + :expanded-indicator "-" + :collapsed-indicator "+" + :key 'message-details + (vui-vstack + :spacing 0 + (vui-text (format "From: %s <%s>" + (himalaya-ui--sender envelope) + (or (plist-get envelope :from-address) "")) + :face 'shadow) + (vui-text (format "To: %s <%s>" + (himalaya-ui--recipient envelope) + (or (plist-get envelope :to-address) "")) + :face 'shadow) + (vui-text (format "ID: %s" (plist-get envelope :id)) :face 'shadow) + (vui-text (format "Flags: %s" + (mapconcat (lambda (flag) (format "%s" flag)) + (or (plist-get envelope :flags) nil) ", ")) + :face 'shadow)))) + (let ((navigation-actions + (vui-hstack + :spacing 2 + (himalaya-ui--quiet-button "back" 'link #'himalaya-ui-back-or-quit) + (himalaya-ui--quiet-button "reply" 'link #'himalaya-ui-reply) + (himalaya-ui--quiet-button "reply all" 'link #'himalaya-ui-reply-all) + (himalaya-ui--quiet-button "forward" 'link #'himalaya-ui-forward))) + (message-actions + (vui-hstack + :spacing 2 + (himalaya-ui--quiet-button "seen" 'link #'himalaya-ui-toggle-seen) + (himalaya-ui--quiet-button "flag" 'link #'himalaya-ui-toggle-flagged) + (himalaya-ui--quiet-button "archive" 'warning #'himalaya-ui-archive) + (himalaya-ui--quiet-button "delete" 'error #'himalaya-ui-delete) + (himalaya-ui--quiet-button "attachments" 'link #'himalaya-ui-download)))) + (if (>= width 73) + (vui-hstack :spacing 2 navigation-actions message-actions) + (vui-vstack :spacing 0 navigation-actions message-actions))) + (vui-text (make-string (max 1 width) ?-) :face 'shadow) + (cond + (loading + (vui-box (vui-text "Loading preview…" :face 'warning) + :width width :align :center)) + (error + (vui-box (vui-text (format "Preview failed: %s" error) :face 'error) + :width width :align :center)) + ((string-empty-p (or body "")) + (vui-box (vui-text "This message has no displayable body" :face 'shadow) + :width width :align :center)) + (t + (vui-vstack + :spacing 0 + :indent 2 + (mapcar (lambda (line) (vui-text line)) + (himalaya-ui--wrap-body body body-width)))))))) + +(defun himalaya-ui--mailbox-footer (page count marked query sort width) + (let ((primary "RET open · t thread · m mark · U seen · * flag · a archive · d delete") + (secondary "/ search · c clear · [ ] page · s sort · g refresh · N new · ? help") + (summary (format "page %d · %d messages · %d marked" + page count (length marked))) + (scope (format "%s%s" + (if (string-empty-p query) "all mail" (format "search: %s" query)) + (if sort (format " · %s" sort) "")))) + (if (>= width 110) + (vui-vstack + :spacing 0 + (vui-flex + :width width + :justify :space-between + (vui-text primary :face 'shadow) + (vui-text summary :face 'shadow)) + (vui-flex + :width width + :justify :space-between + (vui-text secondary :face 'shadow) + (vui-text scope :face 'shadow))) + (vui-vstack + :spacing 0 + (vui-text primary :face 'shadow) + (vui-text summary :face 'shadow) + (vui-text secondary :face 'shadow) + (vui-text scope :face 'shadow))))) + +(defun himalaya-ui--reader-footer (view width) + (let ((keys "r reply · R reply all · f forward · a archive · d delete · q back") + (scope (if (eq view 'thread) "thread preview" "message preview"))) + (if (>= width 96) + (vui-flex + :width width + :justify :space-between + (vui-text keys :face 'shadow) + (vui-text scope :face 'shadow)) + (vui-vstack + :spacing 0 + (vui-text keys :face 'shadow) + (vui-text scope :face 'shadow))))) + +(vui-defcomponent himalaya-ui-root () + :state ((accounts nil) + (account nil) + (folders nil) + (folder nil) + (envelopes nil) + (page 1) + (query "") + (sort nil) + (loading t) + (refreshing nil) + (error nil) + (last-sync nil) + (marked nil) + (view 'mailbox) + (message-id nil) + (message-body nil)) + :render + (cl-labels + ((fetch-envelopes + (selected-account selected-folder selected-page selected-query selected-sort clear-marked) + (cl-incf himalaya-ui--mutation-generation) + (let* ((ownership-changed + (or (not (equal selected-account account)) + (not (equal selected-folder folder)))) + (cached (and (not ownership-changed) last-sync)) + (request + (list (cl-incf himalaya-ui--envelopes-request-generation) + selected-account selected-folder selected-page + selected-query selected-sort))) + (setq himalaya-ui--envelopes-request request + himalaya-ui--preview-request nil) + (vui-batch + (vui-set-state :account selected-account) + (vui-set-state :folder selected-folder) + (vui-set-state :page selected-page) + (vui-set-state :query selected-query) + (vui-set-state :sort selected-sort) + (vui-set-state :error nil) + (vui-set-state :loading (not cached)) + (vui-set-state :refreshing (and cached t)) + (vui-set-state :view 'mailbox) + (vui-set-state :message-id nil) + (vui-set-state :message-body nil) + (when ownership-changed + (vui-set-state :envelopes nil) + (vui-set-state :last-sync nil)) + (when (or ownership-changed clear-marked) + (vui-set-state :marked nil))) + (himalaya-client-envelopes + selected-account selected-folder selected-page selected-query selected-sort + (vui-async-callback (result backend-error) + (when (equal request himalaya-ui--envelopes-request) + (if backend-error + (vui-batch + (vui-set-state :loading nil) + (vui-set-state :refreshing nil) + (vui-set-state :error backend-error)) + (vui-batch + (vui-set-state :envelopes (or result nil)) + (vui-set-state :loading nil) + (vui-set-state :refreshing nil) + (vui-set-state :error nil) + (vui-set-state :last-sync (float-time))))))))) + (load-folders + (selected-account) + (cl-incf himalaya-ui--mutation-generation) + (let ((request + (list (cl-incf himalaya-ui--folders-request-generation) + selected-account))) + (setq himalaya-ui--folders-request request + himalaya-ui--envelopes-request nil + himalaya-ui--preview-request nil) + (vui-batch + (vui-set-state :account selected-account) + (vui-set-state :folders nil) + (vui-set-state :folder nil) + (vui-set-state :envelopes nil) + (vui-set-state :marked nil) + (vui-set-state :loading t) + (vui-set-state :refreshing nil) + (vui-set-state :error nil) + (vui-set-state :last-sync nil)) + (himalaya-client-folders + selected-account + (vui-async-callback (result backend-error) + (when (equal request himalaya-ui--folders-request) + (if backend-error + (vui-batch + (vui-set-state :loading nil) + (vui-set-state :error backend-error)) + (let* ((names (himalaya-ui--names result :folders)) + (inbox (seq-find (lambda (name) + (string-equal-ignore-case name "INBOX")) + names)) + (selected-folder (or inbox (car names)))) + (vui-set-state :folders names) + (if selected-folder + (fetch-envelopes selected-account selected-folder 1 "" sort t) + (vui-batch + (vui-set-state :loading nil) + (vui-set-state :error "This account has no folders")))))))))) + (start-up + () + (vui-batch + (vui-set-state :loading t) + (vui-set-state :error nil)) + (himalaya-client-accounts + (vui-async-callback (result backend-error) + (if backend-error + (vui-batch + (vui-set-state :loading nil) + (vui-set-state :error backend-error)) + (let ((names (himalaya-ui--names result :accounts))) + (vui-set-state :accounts names) + (if names + (load-folders (car names)) + (vui-batch + (vui-set-state :loading nil) + (vui-set-state :error "No Himalaya accounts are configured")))))))) + (open-preview + (kind id) + (cl-incf himalaya-ui--mutation-generation) + (let ((request + (list (cl-incf himalaya-ui--preview-request-generation) + kind account folder id))) + (setq himalaya-ui--preview-request request + himalaya-ui--envelopes-request nil) + (vui-batch + (vui-set-state :view (lambda (_current) kind)) + (vui-set-state :message-id id) + (vui-set-state :message-body nil) + (vui-set-state :loading t) + (vui-set-state :refreshing nil) + (vui-set-state :error nil)) + (funcall + (if (eq kind 'thread) #'himalaya-client-thread #'himalaya-client-read) + account folder id + (vui-async-callback (result backend-error) + (when (equal request himalaya-ui--preview-request) + (if backend-error + (vui-batch + (vui-set-state :loading nil) + (vui-set-state :error backend-error)) + (vui-batch + (vui-set-state :message-body (himalaya-ui--body-text result)) + (vui-set-state :loading nil) + (vui-set-state :error nil)))))))) + (refresh-current + () + (if (eq view 'mailbox) + (when (and account folder) + (fetch-envelopes account folder page query sort nil)) + (when message-id + (open-preview view message-id)))) + (finish-mutation + (generation) + (vui-async-callback (_result backend-error) + (when (= generation himalaya-ui--mutation-generation) + (if backend-error + (vui-batch + (vui-set-state :loading nil) + (vui-set-state :refreshing nil) + (vui-set-state :error backend-error)) + (fetch-envelopes account folder page query sort t))))) + (run-bulk + (action ids target) + (when (and account folder ids) + (let* ((generation (cl-incf himalaya-ui--mutation-generation)) + (callback (finish-mutation generation))) + (pcase action + ('seen-add + (himalaya-client-flag account folder "add" ids '("seen") callback)) + ('seen-remove + (himalaya-client-flag account folder "remove" ids '("seen") callback)) + ('flagged-add + (himalaya-client-flag account folder "add" ids '("flagged") callback)) + ('flagged-remove + (himalaya-client-flag account folder "remove" ids '("flagged") callback)) + ('delete + (himalaya-client-delete account folder ids callback)) + ('download + (himalaya-client-download account folder ids callback)) + ('move + (himalaya-client-transfer account folder "move" target ids callback)) + ('copy + (himalaya-client-transfer account folder "copy" target ids callback)))))) + (toggle-seen + (ids) + (let ((make-seen + (seq-some + (lambda (id) + (let ((envelope (himalaya-ui--envelope id envelopes))) + (or (null envelope) (plist-get envelope :unread)))) + ids))) + (run-bulk (if make-seen 'seen-add 'seen-remove) ids nil))) + (toggle-flagged + (ids) + (let ((make-flagged + (seq-some + (lambda (id) + (let ((envelope (himalaya-ui--envelope id envelopes))) + (or (null envelope) (not (plist-get envelope :starred))))) + ids))) + (run-bulk (if make-flagged 'flagged-add 'flagged-remove) ids nil))) + (toggle-mark + (id) + (when (and (eq view 'mailbox) id) + (vui-set-state :marked + (if (member id marked) + (remove id marked) + (cons id marked))))) + (toggle-all + () + (when (eq view 'mailbox) + (let ((ids (mapcar (lambda (envelope) (plist-get envelope :id)) envelopes))) + (vui-set-state + :marked + (if (and ids (seq-every-p (lambda (id) (member id marked)) ids)) + (seq-remove (lambda (id) (member id ids)) marked) + (delete-dups (append ids marked))))))) + (cycle-sort + () + (let ((next-sort (cond + ((null sort) "date desc") + ((equal sort "date desc") "date asc") + ((equal sort "date asc") "subject asc") + (t nil)))) + (fetch-envelopes account folder 1 query next-sort t))) + (go-back + () + (if (eq view 'mailbox) + (quit-window) + (setq himalaya-ui--preview-request nil) + (vui-batch + (vui-set-state :view 'mailbox) + (vui-set-state :message-id nil) + (vui-set-state :message-body nil) + (vui-set-state :loading nil) + (vui-set-state :error nil)))) + (compose + (kind id) + (when account + (himalaya-client-compose account folder id kind)))) + (vui-use-effect () + (start-up) + nil) + (let* ((dispatch (make-hash-table :test 'eq)) + (window (or (get-buffer-window (current-buffer)) (selected-window))) + (width (max 40 (- (window-body-width window) 2))) + (unread (seq-count (lambda (envelope) (plist-get envelope :unread)) envelopes))) + (puthash 'open (vui-async-callback (id) (open-preview 'message id)) dispatch) + (puthash 'thread (vui-async-callback (id) (open-preview 'thread id)) dispatch) + (puthash 'refresh (vui-with-async-context (refresh-current)) dispatch) + (puthash 'search + (vui-async-callback (new-query) + (fetch-envelopes account folder 1 new-query sort t)) + dispatch) + (puthash 'clear + (vui-with-async-context + (fetch-envelopes account folder 1 "" sort t)) + dispatch) + (puthash 'page + (vui-async-callback (new-page) + (fetch-envelopes account folder new-page query sort t)) + dispatch) + (puthash 'sort (vui-with-async-context (cycle-sort)) dispatch) + (puthash 'mark (vui-async-callback (id) (toggle-mark id)) dispatch) + (puthash 'mark-all (vui-with-async-context (toggle-all)) dispatch) + (puthash 'seen (vui-async-callback (ids) (toggle-seen ids)) dispatch) + (puthash 'flagged (vui-async-callback (ids) (toggle-flagged ids)) dispatch) + (puthash 'delete (vui-async-callback (ids) (run-bulk 'delete ids nil)) dispatch) + (puthash 'download (vui-async-callback (ids) (run-bulk 'download ids nil)) dispatch) + (puthash 'transfer + (vui-async-callback (operation target ids) + (run-bulk operation ids target)) + dispatch) + (puthash 'expunge + (vui-with-async-context + (when (and account folder) + (let ((generation (cl-incf himalaya-ui--mutation-generation))) + (himalaya-client-expunge + account folder (finish-mutation generation))))) + dispatch) + (puthash 'compose (vui-async-callback (kind id) (compose kind id)) dispatch) + (puthash 'back (vui-with-async-context (go-back)) dispatch) + (puthash 'current-page page dispatch) + (setq himalaya-ui--dispatch dispatch + himalaya-ui--visible-ids + (mapcar (lambda (envelope) (plist-get envelope :id)) envelopes) + himalaya-ui--folders folders + himalaya-ui--marked marked + himalaya-ui--view view + himalaya-ui--message-id message-id) + (vui-vstack + :spacing 1 + (himalaya-ui--header account folder unread loading refreshing last-sync width) + (if (eq view 'mailbox) + (vui-vstack + :spacing 0 + (himalaya-ui--folder-navigation + accounts account folders folder + (lambda (name) (load-folders name)) + (lambda (name) (fetch-envelopes account name 1 "" sort t)) + (lambda () (refresh-current)) + #'himalaya-ui-search + #'himalaya-ui-clear-search + #'himalaya-ui-compose) + (when refreshing + (vui-text "Refreshing — cached messages remain visible" :face 'warning)) + (when (and error last-sync) + (vui-text (format "Refresh failed — showing cached mail: %s" error) + :face 'error)) + (cond + ((and loading (null last-sync)) + (vui-box (vui-text "Loading mailbox…" :face 'warning) + :width width :align :center)) + ((and error (null last-sync)) + (vui-vstack + :spacing 1 + (vui-box (vui-text "Mailbox unavailable" :face 'error) + :width width :align :center) + (vui-box (vui-text error :face 'error) + :width width :align :center) + (vui-box (himalaya-ui--quiet-button + "retry" 'link (lambda () (start-up))) + :width width :align :center))) + ((null envelopes) + (himalaya-ui--empty-state folder query width)) + ((>= width 88) + (himalaya-ui--wide-messages + envelopes marked + (lambda (id) (open-preview 'message id)) + width)) + (t + (himalaya-ui--compact-messages + envelopes marked + (lambda (id) (open-preview 'message id)) + width))) + (himalaya-ui--mailbox-footer + page (length envelopes) marked query sort width)) + (vui-vstack + :spacing 1 + (himalaya-ui--reader + view account folder + (himalaya-ui--envelope message-id envelopes) + message-body loading error width) + (himalaya-ui--reader-footer view width))))))) + +(defun himalaya-ui--invoke (action arguments) + (let ((callback (and himalaya-ui--dispatch + (gethash action himalaya-ui--dispatch)))) + (if callback + (apply callback arguments) + (message "Himalaya UI is not ready")))) + +(defun himalaya-ui--id-at-point () + (or (let ((key (vui-key-at))) + (and (member key himalaya-ui--visible-ids) key)) + (save-excursion + (forward-line -1) + (let ((start (line-beginning-position))) + (forward-line 3) + (cl-loop for position from start below (point) + for key = (vui-key-at position) + when (member key himalaya-ui--visible-ids) + return key))))) + +(defun himalaya-ui--targets () + (if (eq himalaya-ui--view 'mailbox) + (or himalaya-ui--marked + (let ((id (himalaya-ui--id-at-point))) + (and id (list id)))) + (and himalaya-ui--message-id (list himalaya-ui--message-id)))) + +(defun himalaya-ui--require-targets (action) + (let ((ids (himalaya-ui--targets))) + (if ids + (progn (himalaya-ui--invoke action (list ids)) t) + (message "No message selected") + nil))) + +(defun himalaya-ui--move-row (direction) + (if (null himalaya-ui--visible-ids) + (message "No message rows") + (let ((move (if (> direction 0) #'vui-forward #'vui-backward)) + (first-position nil) + (found nil) + (finished nil)) + (while (not finished) + (funcall move) + (let ((position (point)) + (key (vui-key-at))) + (cond + ((and first-position (= position first-position)) + (setq finished t)) + ((member key himalaya-ui--visible-ids) + (setq found t + finished t)) + (t + (unless first-position + (setq first-position position)))))) + (unless found + (message "No message rows"))))) + +(defun himalaya-ui-next-row () + "Move to the next message row." + (interactive) + (himalaya-ui--move-row 1)) + +(defun himalaya-ui-previous-row () + "Move to the previous message row." + (interactive) + (himalaya-ui--move-row -1)) + +(defun himalaya-ui-open () + "Open the message preview at point." + (interactive) + (if-let* ((id (or (himalaya-ui--id-at-point) himalaya-ui--message-id))) + (himalaya-ui--invoke 'open (list id)) + (message "No message selected"))) + +(defun himalaya-ui-open-thread () + "Open the thread preview at point." + (interactive) + (if-let* ((id (or (himalaya-ui--id-at-point) himalaya-ui--message-id))) + (himalaya-ui--invoke 'thread (list id)) + (message "No message selected"))) + +(defun himalaya-ui-refresh () + "Refresh the current view." + (interactive) + (himalaya-ui--invoke 'refresh nil)) + +(defun himalaya-ui-search () + "Search the current folder." + (interactive) + (himalaya-ui--invoke + 'search + (list (read-string "Search mail: " nil nil "")))) + +(defun himalaya-ui-clear-search () + "Clear the current search." + (interactive) + (himalaya-ui--invoke 'clear nil)) + +(defun himalaya-ui-next-page () + "Open the next mailbox page." + (interactive) + (let ((page (or (and himalaya-ui--dispatch + (gethash 'current-page himalaya-ui--dispatch)) + 1))) + (himalaya-ui--invoke 'page (list (1+ page))))) + +(defun himalaya-ui-previous-page () + "Open the previous mailbox page." + (interactive) + (let ((page (or (and himalaya-ui--dispatch + (gethash 'current-page himalaya-ui--dispatch)) + 1))) + (if (> page 1) + (himalaya-ui--invoke 'page (list (1- page))) + (message "Already on the first page")))) + +(defun himalaya-ui-cycle-sort () + "Cycle mailbox sorting." + (interactive) + (himalaya-ui--invoke 'sort nil)) + +(defun himalaya-ui-toggle-mark () + "Toggle the mark on the message at point." + (interactive) + (if (not (eq himalaya-ui--view 'mailbox)) + (message "Marks are only available in the mailbox") + (if-let* ((id (himalaya-ui--id-at-point))) + (himalaya-ui--invoke 'mark (list id)) + (message "No message selected")))) + +(defun himalaya-ui-toggle-mark-all () + "Toggle marks on all visible messages." + (interactive) + (if (eq himalaya-ui--view 'mailbox) + (himalaya-ui--invoke 'mark-all nil) + (message "Marks are only available in the mailbox"))) + +(defun himalaya-ui-toggle-seen () + "Toggle the seen flag on the current targets." + (interactive) + (himalaya-ui--require-targets 'seen)) + +(defun himalaya-ui-toggle-flagged () + "Toggle the flagged flag on the current targets." + (interactive) + (himalaya-ui--require-targets 'flagged)) + +(defun himalaya-ui--choose-folder (prompt) + (if himalaya-ui--folders + (completing-read prompt himalaya-ui--folders nil t) + (message "No folders are available") + nil)) + +(defun himalaya-ui-archive () + "Move the current targets to Archive." + (interactive) + (let ((ids (himalaya-ui--targets))) + (if (null ids) + (message "No message selected") + (let ((archive (seq-find (lambda (name) + (string-equal-ignore-case name "Archive")) + himalaya-ui--folders))) + (setq archive (or archive (himalaya-ui--choose-folder "Archive to: "))) + (when archive + (himalaya-ui--invoke 'transfer (list 'move archive ids))))))) + +(defun himalaya-ui-move () + "Move the current targets to a folder." + (interactive) + (let ((ids (himalaya-ui--targets))) + (if (null ids) + (message "No message selected") + (let ((target (himalaya-ui--choose-folder "Move to: "))) + (when target + (himalaya-ui--invoke 'transfer (list 'move target ids))))))) + +(defun himalaya-ui-copy () + "Copy the current targets to a folder." + (interactive) + (let ((ids (himalaya-ui--targets))) + (if (null ids) + (message "No message selected") + (let ((target (himalaya-ui--choose-folder "Copy to: "))) + (when target + (himalaya-ui--invoke 'transfer (list 'copy target ids))))))) + +(defun himalaya-ui-delete () + "Flag the current targets as deleted." + (interactive) + (himalaya-ui--require-targets 'delete)) + +(defun himalaya-ui-expunge () + "Expunge deleted messages after confirmation." + (interactive) + (when (yes-or-no-p "Permanently expunge deleted messages? ") + (himalaya-ui--invoke 'expunge nil))) + +(defun himalaya-ui-download () + "Download attachments from the current targets." + (interactive) + (himalaya-ui--require-targets 'download)) + +(defun himalaya-ui-compose () + "Compose a new message." + (interactive) + (himalaya-ui--invoke 'compose (list nil nil))) + +(defun himalaya-ui-reply () + "Reply to the selected message." + (interactive) + (if-let* ((id (or (himalaya-ui--id-at-point) himalaya-ui--message-id))) + (himalaya-ui--invoke 'compose (list 'reply id)) + (message "No message selected"))) + +(defun himalaya-ui-reply-all () + "Reply to all recipients of the selected message." + (interactive) + (if-let* ((id (or (himalaya-ui--id-at-point) himalaya-ui--message-id))) + (himalaya-ui--invoke 'compose (list 'reply-all id)) + (message "No message selected"))) + +(defun himalaya-ui-forward () + "Forward the selected message." + (interactive) + (if-let* ((id (or (himalaya-ui--id-at-point) himalaya-ui--message-id))) + (himalaya-ui--invoke 'compose (list 'forward id)) + (message "No message selected"))) + +(defun himalaya-ui-back-or-quit () + "Return to the mailbox or quit its window." + (interactive) + (himalaya-ui--invoke 'back nil)) + +(defun himalaya-ui-help () + "Show Himalaya UI keys." + (interactive) + (with-help-window "*Himalaya Help*" + (princ "Himalaya\n\n") + (princ "n/p or j/k next/previous message\n") + (princ "RET/o open preview\n") + (princ "t thread preview\n") + (princ "g refresh\n") + (princ "/ / c search / clear search\n") + (princ "[ / ] previous / next page\n") + (princ "s cycle sort\n") + (princ "m / M mark one / all visible\n") + (princ "U / * toggle seen / flagged\n") + (princ "a / v / y archive / move / copy\n") + (princ "d / x deleted flag / expunge\n") + (princ "A download attachments\n") + (princ "N compose\n") + (princ "r / R / f reply / reply all / forward\n") + (princ "q back / quit\n") + (princ "TAB next VUI control\n"))) + +(defvar himalaya-ui-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map vui-mode-map) + (define-key map (kbd "n") #'himalaya-ui-next-row) + (define-key map (kbd "p") #'himalaya-ui-previous-row) + (define-key map (kbd "RET") #'himalaya-ui-open) + (define-key map (kbd "o") #'himalaya-ui-open) + (define-key map (kbd "t") #'himalaya-ui-open-thread) + (define-key map (kbd "g") #'himalaya-ui-refresh) + (define-key map (kbd "/") #'himalaya-ui-search) + (define-key map (kbd "c") #'himalaya-ui-clear-search) + (define-key map (kbd "]") #'himalaya-ui-next-page) + (define-key map (kbd "[") #'himalaya-ui-previous-page) + (define-key map (kbd "s") #'himalaya-ui-cycle-sort) + (define-key map (kbd "m") #'himalaya-ui-toggle-mark) + (define-key map (kbd "M") #'himalaya-ui-toggle-mark-all) + (define-key map (kbd "U") #'himalaya-ui-toggle-seen) + (define-key map (kbd "*") #'himalaya-ui-toggle-flagged) + (define-key map (kbd "a") #'himalaya-ui-archive) + (define-key map (kbd "v") #'himalaya-ui-move) + (define-key map (kbd "y") #'himalaya-ui-copy) + (define-key map (kbd "d") #'himalaya-ui-delete) + (define-key map (kbd "x") #'himalaya-ui-expunge) + (define-key map (kbd "A") #'himalaya-ui-download) + (define-key map (kbd "N") #'himalaya-ui-compose) + (define-key map (kbd "r") #'himalaya-ui-reply) + (define-key map (kbd "R") #'himalaya-ui-reply-all) + (define-key map (kbd "f") #'himalaya-ui-forward) + (define-key map (kbd "q") #'himalaya-ui-back-or-quit) + (define-key map (kbd "?") #'himalaya-ui-help) + map)) + +(define-derived-mode himalaya-ui-mode vui-mode "Himalaya" + "Major mode for the Himalaya VUI client." + (hl-line-mode 1) + (setq-local truncate-lines t)) + +(with-eval-after-load 'evil + (evil-set-initial-state 'himalaya-ui-mode 'motion) + (evil-define-key* '(motion normal) himalaya-ui-mode-map + (kbd "j") #'himalaya-ui-next-row + (kbd "k") #'himalaya-ui-previous-row + (kbd "p") #'himalaya-ui-previous-row + (kbd "RET") #'himalaya-ui-open + (kbd "o") #'himalaya-ui-open + (kbd "t") #'himalaya-ui-open-thread + (kbd "g") #'himalaya-ui-refresh + (kbd "/") #'himalaya-ui-search + (kbd "c") #'himalaya-ui-clear-search + (kbd "]") #'himalaya-ui-next-page + (kbd "[") #'himalaya-ui-previous-page + (kbd "s") #'himalaya-ui-cycle-sort + (kbd "m") #'himalaya-ui-toggle-mark + (kbd "M") #'himalaya-ui-toggle-mark-all + (kbd "U") #'himalaya-ui-toggle-seen + (kbd "*") #'himalaya-ui-toggle-flagged + (kbd "a") #'himalaya-ui-archive + (kbd "v") #'himalaya-ui-move + (kbd "y") #'himalaya-ui-copy + (kbd "d") #'himalaya-ui-delete + (kbd "x") #'himalaya-ui-expunge + (kbd "A") #'himalaya-ui-download + (kbd "n") #'himalaya-ui-compose + (kbd "N") #'himalaya-ui-compose + (kbd "r") #'himalaya-ui-reply + (kbd "R") #'himalaya-ui-reply-all + (kbd "f") #'himalaya-ui-forward + (kbd "q") #'himalaya-ui-back-or-quit + (kbd "?") #'himalaya-ui-help)) + +;;;###autoload +(defun himalaya-ui () + "Open the Himalaya VUI mail client." + (interactive) + (let ((buffer (get-buffer-create "*Himalaya*"))) + (unless (vui-get-instance buffer) + (with-current-buffer buffer + (himalaya-ui-mode)) + (vui-mount (vui-component 'himalaya-ui-root) buffer) + (with-current-buffer buffer + (vui-rerender-on-resize))) + (pop-to-buffer buffer))) + +(provide 'himalaya-ui) +;;; himalaya-ui.el ends here diff --git a/lisp/my-mode-line.el b/lisp/my-mode-line.el index b6fe532..11eb88b 100644 --- a/lisp/my-mode-line.el +++ b/lisp/my-mode-line.el @@ -2,36 +2,56 @@ (require 'mode-line-maker) -(defface my/mode-line-helix-normal - '((t (:background "#89b4fa" :foreground "#1e1e2e" :weight bold))) - "Face for the helix normal state indicator.") +(defface my/mode-line-evil-normal + '((t (:inherit font-lock-keyword-face :weight bold))) + "Face for the evil normal state indicator.") -(defface my/mode-line-helix-insert - '((t (:background "#a6e3a1" :foreground "#1e1e2e" :weight bold))) - "Face for the helix insert state indicator.") +(defface my/mode-line-evil-insert + '((t (:inherit success :weight bold))) + "Face for the evil insert state indicator.") + +(defface my/mode-line-evil-visual + '((t (:inherit warning :weight bold))) + "Face for the evil visual state indicator.") + +(defface my/mode-line-evil-replace + '((t (:inherit error :weight bold))) + "Face for the evil replace state indicator.") + +(defface my/mode-line-evil-motion + '((t (:inherit font-lock-constant-face :weight bold))) + "Face for the evil motion state indicator.") + +(defface my/mode-line-evil-emacs + '((t (:inherit font-lock-builtin-face :weight bold))) + "Face for the evil Emacs state indicator.") + +(defface my/mode-line-buffer-icon-face + '((t (:inherit mode-line-buffer-id))) + "Face for the current buffer's file or mode icon.") (defface my/mode-line-irc-face - '((t (:foreground "#94e2d5" :weight bold))) + '((t (:inherit font-lock-builtin-face :weight bold))) "Face for the IRC activity indicator.") (defface my/mode-line-mu4e-face - '((t (:foreground "#f9e2af" :weight bold))) + '((t (:inherit warning :weight bold))) "Face for the unread mail indicator.") (defface my/mode-line-time-face - '((t (:foreground "#89dceb"))) + '((t (:inherit font-lock-constant-face))) "Face for the time segment.") (defface my/mode-line-state-saved-face - '((t (:foreground "#a6e3a1"))) + '((t (:inherit success))) "Face for the saved buffer state icon.") (defface my/mode-line-state-modified-face - '((t (:foreground "#fab387" :weight bold))) + '((t (:inherit warning :weight bold))) "Face for the modified buffer state icon.") (defface my/mode-line-state-read-only-face - '((t (:foreground "#f38ba8"))) + '((t (:inherit error))) "Face for the read-only buffer state icon.") (defvar-local my/mode-line--buffer-title nil) @@ -64,57 +84,81 @@ the project root, falling back to the plain buffer name." (buffer-name)))) (defun my/mode-line--nerd-icons-p () + "Return non-nil when Nerd Icons are enabled and available." (and (bound-and-true-p ek-use-nerd-fonts) (require 'nerd-icons nil t))) +(defun my/mode-line--icon (name face &optional fallback) + "Render Nerd icon NAME with FACE, or FALLBACK when unavailable." + (if (my/mode-line--nerd-icons-p) + (propertize (nerd-icons-mdicon name) 'face face) + (propertize (or fallback "") 'face face))) + (defun my/mode-line-buffer-icon () "Nerd icon for the current buffer, or nil." (when (my/mode-line--nerd-icons-p) (or (and buffer-file-name - (ignore-errors (nerd-icons-icon-for-file buffer-file-name))) - (ignore-errors (nerd-icons-icon-for-mode major-mode))))) - -(defun my/mode-line-helix-state () - "Colored single-letter indicator for the current helix state." - (when (and (boundp 'helix--current-state) helix--current-state) - (let* ((tag (upcase (substring (symbol-name helix--current-state) 0 1))) - (face (intern-soft (format "my/mode-line-helix-%s" helix--current-state)))) - (propertize (format " %s " tag) 'face (or face 'my/mode-line-helix-normal))))) + (ignore-errors + (nerd-icons-icon-for-file + buffer-file-name :face 'my/mode-line-buffer-icon-face))) + (ignore-errors + (nerd-icons-icon-for-mode + major-mode :face 'my/mode-line-buffer-icon-face))))) + +(defconst my/mode-line--evil-states + '((normal "N" my/mode-line-evil-normal) + (insert "I" my/mode-line-evil-insert) + (visual "V" my/mode-line-evil-visual) + (replace "R" my/mode-line-evil-replace) + (motion "M" my/mode-line-evil-motion) + (emacs "E" my/mode-line-evil-emacs)) + "Display labels and theme-derived faces for Evil states.") + +(defun my/mode-line-evil-state () + "Compact, theme-aware indicator for the current Evil state." + (when (bound-and-true-p evil-state) + (let* ((entry (assq evil-state my/mode-line--evil-states)) + (tag (or (nth 1 entry) + (upcase (substring (symbol-name evil-state) 0 1)))) + (face (or (nth 2 entry) 'my/mode-line-evil-normal))) + (propertize (format " %s " tag) 'face face)))) (defun my/mode-line-buffer-state () - "Buffer state icon: lock (read-only), pencil-alert (modified), save (saved)." + "Render a clean lock, edit, or saved indicator for the current buffer." (cond (buffer-read-only - (if (my/mode-line--nerd-icons-p) - (propertize (nerd-icons-mdicon "nf-md-lock") - 'face 'my/mode-line-state-read-only-face) - "%%")) + (my/mode-line--icon "nf-md-lock" + 'my/mode-line-state-read-only-face "RO")) ((buffer-modified-p) - (if (my/mode-line--nerd-icons-p) - (propertize (nerd-icons-mdicon "nf-md-content_save_alert") - 'face 'my/mode-line-state-modified-face) - "**")) + (my/mode-line--icon "nf-md-pencil" + 'my/mode-line-state-modified-face "*")) (t - (if (my/mode-line--nerd-icons-p) - (propertize (nerd-icons-mdicon "nf-md-content_save") - 'face 'my/mode-line-state-saved-face) - "--")))) + (my/mode-line--icon "nf-md-check" + 'my/mode-line-state-saved-face "=")))) + +(defun my/mode-line-remote () + "Show a remote indicator only for an actual remote directory. +Unlike the built-in `mode-line-remote', local buffers render nothing instead +of a literal dash." + (when (file-remote-p default-directory) + (my/mode-line--icon "nf-md-cloud_outline" + 'font-lock-constant-face "@"))) (defun my/mode-line-irc () "IRC activity indicator: icon plus number of buffers with unread activity." (when (bound-and-true-p erc-modified-channels-alist) - (let ((icon (and (my/mode-line--nerd-icons-p) - (nerd-icons-mdicon "nf-md-message_badge_outline")))) - (propertize (format "%s %d" (or icon "irc") + (let ((icon (my/mode-line--icon "nf-md-forum_outline" + 'my/mode-line-irc-face "irc"))) + (propertize (format "%s %d" icon (length erc-modified-channels-alist)) 'face 'my/mode-line-irc-face)))) (defun my/mode-line-mu4e () "Unread mail indicator from mu4e-alert, or nil when mu4e is not in use." (when (bound-and-true-p mu4e-alert-mode-line) - (let ((icon (and (my/mode-line--nerd-icons-p) - (nerd-icons-mdicon "nf-md-email_alert_outline")))) - (propertize (format "%s %s" (or icon "mail") + (let ((icon (my/mode-line--icon "nf-md-email_outline" + 'my/mode-line-mu4e-face "mail"))) + (propertize (format "%s %s" icon (string-trim mu4e-alert-mode-line)) 'face 'my/mode-line-mu4e-face)))) @@ -135,16 +179,33 @@ the project root, falling back to the plain buffer name." (propertize (if icon (concat icon " " time) time) 'face 'my/mode-line-time-face)))) +(defun my/mode-line-sync-theme (&optional _theme) + "Make helper padding inherit the live header-line theme face. +Optional THEME is ignored so this function also fits +`enable-theme-functions'." + (set-face-attribute 'mode-line-maker-padding-face nil + :inherit 'header-line + :foreground 'unspecified + :background 'unspecified + :box nil + :overline nil + :underline nil + :inverse-video nil + :strike-through nil)) + (defun my/mode-line-install () "Install the custom mode-line built with mode-line-maker. The mode-line lives at the top of the window via `header-line-format'; the bottom mode-line is hidden." (setq global-mode-string (delq 'display-time-string global-mode-string)) + (my/mode-line-sync-theme) + (add-hook 'enable-theme-functions #'my/mode-line-sync-theme) (setq-default mode-line-format nil) (setq-default header-line-format (mode-line-maker - '((:eval (my/mode-line-helix-state)) " " - (:eval (my/mode-line-buffer-state)) mode-line-remote " " + '((:eval (my/mode-line-evil-state)) " " + (:eval (my/mode-line-buffer-state)) + (:eval (my/mode-line-remote)) " " (:eval (my/mode-line-buffer-icon)) " " (:eval (propertize (my/mode-line-buffer-name) 'face 'mode-line-buffer-id diff --git a/test/fossil-ui-test.el b/test/fossil-ui-test.el new file mode 100644 index 0000000..bc1e8ce --- /dev/null +++ b/test/fossil-ui-test.el @@ -0,0 +1,248 @@ +;;; fossil-ui-test.el --- Tests for fossil-ui -*- lexical-binding: t; -*- + +(require 'ert) +(require 'fossil-ui) + +(defun fossil-ui-test--call (directory &rest args) + "Run Fossil ARGS in DIRECTORY and fail the test on error." + (pcase-let ((`(,code ,output) (apply #'fossil-ui--call-in directory args))) + (unless (zerop code) + (ert-fail (format "fossil %S failed (%d): %s" args code output))) + output)) + +(defun fossil-ui-test--write (file contents) + "Write CONTENTS to FILE." + (make-directory (file-name-directory file) t) + (with-temp-file file (insert contents))) + +(defmacro fossil-ui-test--with-checkout (&rest body) + "Create a temporary Fossil checkout and evaluate BODY there." + (declare (indent 0) (debug t)) + `(let* ((base (make-temp-file "fossil-ui-test-" t)) + (repo (expand-file-name "project.fossil" base)) + (root (file-name-as-directory (expand-file-name "checkout" base)))) + (unwind-protect + (progn + (make-directory root) + (fossil-ui-test--call base "init" repo) + (fossil-ui-test--call base "user" "new" "tester" + "tester@example.invalid" "test-password" "-R" repo) + (fossil-ui-test--call base "user" "default" "tester" "-R" repo) + (fossil-ui-test--call root "open" repo) + (fossil-ui-test--write (expand-file-name "tracked.txt" root) "initial\n") + (fossil-ui-test--call root "add" "tracked.txt") + (fossil-ui-test--call root "commit" "--nosync" "-m" "initial") + ,@body) + (delete-directory base t)))) + +(ert-deftest fossil-ui-parse-change-line-preserves-spaces () + (should + (equal (fossil-ui--parse-change-line "EDITED \"dir/file name.el\"") + '(:status "EDITED" :path "dir/file name.el")))) + +(ert-deftest fossil-ui-parse-numstat-text-and-spaced-paths () + (should (equal (fossil-ui--parse-numstat-line "12\t3\tdir/file name.el") + '(:path "dir/file name.el" :insertions 12 :deletions 3 + :binary nil)))) + +(ert-deftest fossil-ui-parse-numstat-binary-and-deleted-files () + (should (equal (fossil-ui--parse-numstat-line "-\t-\timage file.png") + '(:path "image file.png" :insertions nil :deletions nil + :binary t))) + (should (equal (fossil-ui--parse-numstat-line "0 19 old file.txt") + '(:path "old file.txt" :insertions 0 :deletions 19 + :binary nil)))) + +(ert-deftest fossil-ui-numstat-association-handles-extras () + (let ((stats (make-hash-table :test #'equal))) + (puthash "edited.txt" '(:path "edited.txt" :insertions 4 :deletions 2) + stats) + (should + (equal (fossil-ui--attach-numstat + '((:status "EDITED" :path "edited.txt") + (:status "EXTRA" :path "new file.txt")) stats) + '((:status "EDITED" :path "edited.txt" :insertions 4 :deletions 2) + (:status "EXTRA" :path "new file.txt" :extra t)))))) + +(ert-deftest fossil-ui-snapshot-finds-edited-and-extra-files () + (fossil-ui-test--with-checkout + (fossil-ui-test--write (expand-file-name "tracked.txt" root) "changed content\n") + (fossil-ui-test--write (expand-file-name "extra file.txt" root) "extra\n") + (let* ((snapshot (fossil-ui--snapshot root)) + (changes (plist-get snapshot :changes))) + (should (equal (plist-get snapshot :root) root)) + (should (cl-find-if + (lambda (change) + (and (equal (plist-get change :status) "EDITED") + (equal (plist-get change :path) "tracked.txt"))) + changes)) + (should (cl-find-if + (lambda (change) + (and (equal (plist-get change :status) "EXTRA") + (equal (plist-get change :path) "extra file.txt"))) + changes)) + (let ((edited (cl-find "tracked.txt" changes + :key (lambda (change) (plist-get change :path)) + :test #'equal))) + (should (numberp (plist-get edited :insertions))) + (should (numberp (plist-get edited :deletions))))))) + +(ert-deftest fossil-ui-snapshot-retains-only-live-selections () + (fossil-ui-test--with-checkout + (fossil-ui-test--write (expand-file-name "tracked.txt" root) "changed content\n") + (let ((snapshot (fossil-ui--snapshot root '("tracked.txt" "gone.txt")))) + (should (equal (plist-get snapshot :selected) '("tracked.txt")))))) + +(ert-deftest fossil-ui-branch-json-includes-new-branch () + (fossil-ui-test--with-checkout + (fossil-ui-test--write (expand-file-name "tracked.txt" root) "feature content\n") + (fossil-ui-test--call root "commit" "--hash" "--nosync" "--branch" "feature" + "-m" "start feature") + (should (member "feature" (fossil-ui--branches root))))) + +(ert-deftest fossil-ui-render-fits-common-widths-and-heights () + (fossil-ui-test--with-checkout + (fossil-ui-test--write (expand-file-name "tracked.txt" root) "changed content\n") + (let ((textui-state (fossil-ui--snapshot root '("tracked.txt")))) + (dolist (height '(18 32 70)) + (setq textui-state (plist-put textui-state :height height)) + (dolist (width '(80 120 190)) + (let* ((frame (fossil-ui--frame width)) + (rendered (substring-no-properties + (textui--render-specs + (textui--prepare-frame frame) width)))) + (should (string-match-p "tracked.txt" rendered)) + (should (string-match-p "\\[x\\].*tracked.txt" rendered)) + (should (string-match-p + "Repository.*Checkout.*Synchronization" rendered)) + (when (= width 80) + (should (string-match-p "EDITED.*[+].*−" rendered)) + (should-not (string-match-p "Changes.*Recent commits" rendered))) + (when (>= width fossil-ui--wide-layout-width) + (should (string-match-p "Changes.*Recent commits" rendered))) + (dolist (line (split-string rendered "\n")) + (should (<= (string-width (string-trim-right line)) + (if fossil-ui-content-width + (min width fossil-ui-content-width) + width)))) + (when (= width 190) + (should (cl-some (lambda (line) (= (string-width line) 190)) + (split-string rendered "\n")))))))))) + +(ert-deftest fossil-ui-icons-have-portable-fallback () + (let ((fossil-ui-use-icons nil)) + (should (equal (fossil-ui--icon 'repository) "R")) + (should (equal (fossil-ui--status-icon "EXTRA") "?"))) + (let ((fossil-ui-use-icons 'auto)) + (cl-letf (((symbol-function 'display-graphic-p) (lambda (&optional _) nil))) + (should (equal (fossil-ui--icon 'branch) "B"))))) + +(ert-deftest fossil-ui-metadata-grid-reduces-columns-responsively () + (should (= (fossil-ui--metadata-columns 80) 3)) + (should (= (fossil-ui--metadata-columns 70) 2)) + (should (= (fossil-ui--metadata-columns 23) 1))) + +(ert-deftest fossil-ui-render-shows-clean-busy-error-and-no-remote-cards () + (let* ((textui-state + '(:root "/tmp/project/" + :repository "/tmp/project.fossil" + :checkout "0123456789abcdef" + :branch "trunk" + :autosync "off" + :remote nil + :changes nil + :selected nil + :timeline nil + :busy "sync" + :error "network unavailable" + :height 32)) + (rendered + (substring-no-properties + (textui--render-specs + (textui--prepare-frame (fossil-ui--frame 120)) 120)))) + (should (string-match-p "Working checkout is clean" rendered)) + (should (string-match-p "Running" rendered)) + (should (string-match-p "sync is running" rendered)) + (should (string-match-p "Error" rendered)) + (should (string-match-p "network unavailable" rendered)) + (should (string-match-p "no remote" rendered)))) + +(ert-deftest fossil-ui-highlight-range-stays-inside-file-widget () + (with-temp-buffer + (insert "│ ") + (let ((begin (point))) + (insert (propertize "[x] README.org" 'fossil-ui-path "README.org")) + (let ((end (point))) + (insert " │ Recent commits │") + (goto-char begin) + (pcase-let ((`(,range-begin . ,range-end) (fossil-ui--card-range))) + (should (= range-begin begin)) + (should (= range-end end)) + (should (< range-end (line-end-position)))))))) + +(ert-deftest fossil-ui-partial-commit-leaves-unselected-file-dirty () + (fossil-ui-test--with-checkout + (fossil-ui-test--write (expand-file-name "other.txt" root) "other initial\n") + (fossil-ui-test--call root "add" "other.txt") + (fossil-ui-test--call root "commit" "--hash" "--nosync" "-m" "add other") + (fossil-ui-test--write (expand-file-name "tracked.txt" root) "tracked change\n") + (fossil-ui-test--write (expand-file-name "other.txt" root) "other change\n") + (fossil-ui-test--call root "commit" "--hash" "--nosync" "--no-prompt" + "--comment" "partial" "--" "tracked.txt") + (let ((changes (fossil-ui--changes root))) + (should-not (cl-find "tracked.txt" changes + :key (lambda (change) (plist-get change :path)) + :test #'equal)) + (should (cl-find "other.txt" changes + :key (lambda (change) (plist-get change :path)) + :test #'equal))))) + +(ert-deftest fossil-ui-diff-produces-navigable-hunks () + (fossil-ui-test--with-checkout + (fossil-ui-test--write (expand-file-name "tracked.txt" root) + "first changed line\nsecond line\n") + (let ((diff (fossil-ui-test--call + root "diff" "--internal" "--unified" "--" "tracked.txt"))) + (should (string-match-p "^@@ " diff)) + (with-temp-buffer + (fossil-ui-diff-mode) + (should (eq (key-binding (kbd "]c")) #'diff-hunk-next)) + (should (eq (key-binding (kbd "[c")) #'diff-hunk-prev)) + (should (eq (key-binding (kbd "TAB")) #'outline-toggle-children)))))) + +(ert-deftest fossil-ui-delta-render-keeps-hunks-and-emacs-faces () + (skip-unless (executable-find fossil-ui-delta-program)) + (let* ((raw (concat "Index: example.el\n" + "==================================================================\n" + "--- example.el\n" + "+++ example.el\n" + "@@ -1,1 +1,1 @@\n" + "-(message \"old\")\n" + "+(message \"new\")\n")) + (fossil-ui-diff-renderer 'delta) + (rendered (fossil-ui--render-diff raw))) + (should (string-search "@@ -1,1 +1,1 @@" rendered)) + (should-not (string-search (string ?\e) rendered)) + (should (text-property-not-all 0 (length rendered) 'face nil rendered)))) + +(ert-deftest fossil-ui-status-opens-rendered-dashboard () + (fossil-ui-test--with-checkout + (fossil-ui-test--write (expand-file-name "tracked.txt" root) "changed content\n") + (let ((buffer (save-window-excursion (fossil-ui-status root)))) + (unwind-protect + (with-current-buffer buffer + (should (derived-mode-p 'fossil-ui-mode)) + (should (equal default-directory root)) + (goto-char (point-min)) + (should (text-property-search-forward + 'fossil-ui-path "tracked.txt" #'equal))) + (when (buffer-live-p buffer) (kill-buffer buffer)))))) + +(ert-deftest fossil-ui-rejects-directory-without-checkout () + (let ((directory (make-temp-file "fossil-ui-empty-" t))) + (unwind-protect + (should-error (fossil-ui--checkout-info directory) :type 'user-error) + (delete-directory directory t)))) + +(provide 'fossil-ui-test) +;;; fossil-ui-test.el ends here -- cgit v1.3.1