diff options
| -rwxr-xr-x | bin/project-ctags | 88 | ||||
| -rw-r--r-- | config.el | 254 | ||||
| -rw-r--r-- | config.org | 331 | ||||
| -rw-r--r-- | elpaca-lock.eld | 8 | ||||
| -rw-r--r-- | lisp/fossil-ui.el | 1833 | ||||
| -rw-r--r-- | test/fossil-ui-test.el | 73 | ||||
| -rw-r--r-- | themes/tinty-theme.el | 138 |
7 files changed, 2221 insertions, 504 deletions
diff --git a/bin/project-ctags b/bin/project-ctags index ec28964..46c8561 100755 --- a/bin/project-ctags +++ b/bin/project-ctags @@ -2,6 +2,7 @@ import argparse import ast import fcntl +import functools import hashlib import json import os @@ -36,6 +37,29 @@ PYTHON_SUFFIXES = {".py", ".pyi"} RUST_SUFFIXES = {".rs"} C_SOURCE_SUFFIXES = {".c", ".cc", ".cpp", ".cxx", ".m", ".mm"} C_HEADER_SUFFIXES = {".h", ".hh", ".hpp", ".hxx"} +C3_SUFFIXES = {".c3", ".c3i", ".c3t"} +C3_SKIP = r'(?s:/\*.*?\*/|<\*.*?\*>|`[^`]*`|"(?:\\.|[^"\\])*"|//[^\n]*)(*SKIP)(*F)|(?m)^\h*' +C3_CTAGS_OPTIONS = [ + "--langdef=C3", + "--map-C3=+.c3.c3i.c3t", + "--kinddef-C3=f,function,functions", + "--kinddef-C3=m,macro,macros", + "--kinddef-C3=t,type,types", + "--kinddef-C3=c,constant,constants", + "--kinddef-C3=v,variable,variables", + "--kinddef-C3=n,module,modules", + *[ + rf"--mline-regex-C3=~{C3_SKIP}{pattern}~\1~{kind}~p{{mgroup=1}}" + for pattern, kind in [ + (r"fn\s+[^;{}()]*?(@?[a-z_]\w*)\s*\(", "f"), + (r"macro\s+[^;{}()]*?(@?[a-z_]\w*)\s*\(", "m"), + (r"(?:struct|union|enum|bitstruct|interface|def|typedef|distinct|alias|faultdef|attrdef)\s+(@?[A-Za-z_]\w*)", "t"), + (r"const\s+[^=;{}]*?\b([A-Z_][A-Z_0-9]*)\s*(?=[=;@])", "c"), + (r"module\s+([a-z_]\w*(?:::[a-z_]\w*)*)", "n"), + (r"(?:static\s+|tlocal\s+)?(?:(?:[a-z_]\w*::)*[A-Z]\w*|bool|char|ichar|short|ushort|int|uint|long|ulong|int128|uint128|float|double|float16|float128|usz|isz|uptr|iptr|any|typeid)(?:[*!?]|\[[^\]\n]*\])*\s+([a-z_]\w*)\s*(?=[=;@])", "v"), + ] + ], +] NIX_CTAGS_OPTIONS = [ "--langdef=nix", "--map-nix=+.nix", @@ -84,10 +108,13 @@ def parse_arguments(): parser.add_argument("--python") parser.add_argument("--python-command") parser.add_argument("--cargo") + parser.add_argument("--c3c") + parser.add_argument("--c3-stdlib") parser.add_argument("--source", action="append", default=[]) parser.add_argument("--no-python-deps", action="store_true") parser.add_argument("--no-rust-deps", action="store_true") parser.add_argument("--no-c-deps", action="store_true") + parser.add_argument("--no-c3-deps", action="store_true") parser.add_argument("--cache-dir", help="Maintain project and dependency indexes here") parser.add_argument("--force", action="store_true") parser.add_argument("--snapshot-request", help="JSON list of source/snapshot/output mappings") @@ -414,6 +441,41 @@ def extra_source_files(args, root): return sorted(files) +@functools.lru_cache(maxsize=4) +def c3_ctags_options(ctags): + result = subprocess.run( + [ctags, "--options=NONE", "--list-languages"], + text=True, + capture_output=True, + check=True, + ) + return [] if "C3" in result.stdout.splitlines() else C3_CTAGS_OPTIONS + + +def c3_dependency_files(args, root, files): + """Include the installed C3 standard library when indexing a C3 project.""" + if args.no_c3_deps or not any( + path.suffix.lower() in C3_SUFFIXES for path in files + ): + return [] + library = args.c3_stdlib or os.environ.get("C3_STDLIB") + if library: + return walk_files(resolved_path(library, root), C3_SUFFIXES) + compiler = args.c3c or os.environ.get("PROJECT_CTAGS_C3C") or shutil.which("c3c") + if not compiler: + return [] + executable = shutil.which(compiler) or compiler + prefix = resolved_path(executable, root).parent.parent + for candidate in ( + prefix / "lib" / "c3", + prefix / "bin" / "lib", + prefix / "lib", + ): + if (candidate / "std").is_dir(): + return walk_files(candidate, C3_SUFFIXES) + return [] + + def generate_tags(ctags, output, files, mappings=None): output.parent.mkdir(parents=True, exist_ok=True) list_file = tempfile.NamedTemporaryFile(mode="w", prefix="project-ctags-", delete=False) @@ -432,6 +494,7 @@ def generate_tags(ctags, output, files, mappings=None): "--options=NONE", "--output-format=e-ctags", *NIX_CTAGS_OPTIONS, + *c3_ctags_options(ctags), "--languages=all", "--kinds-all=*", "--fields=*", @@ -513,7 +576,11 @@ def dependency_signature(args, root, files): """Track declarations without resolving dependencies on every source edit.""" declarations = [] for path in files: - if path.name in {"Cargo.toml", "Cargo.lock", "pyproject.toml", "uv.lock", "poetry.lock", "pixi.lock", "pixi.toml", "requirements.txt", "compile_commands.json", "flake.lock", "flake.nix", ".envrc"}: + if path.name in { + "Cargo.toml", "Cargo.lock", "project.json", "pyproject.toml", "uv.lock", + "poetry.lock", "pixi.lock", "pixi.toml", "requirements.txt", + "compile_commands.json", "flake.lock", "flake.nix", ".envrc", + }: declarations.append((str(path), file_stamp(path))) elif path.suffix.lower() in C_SOURCE_SUFFIXES | C_HEADER_SUFFIXES: try: @@ -523,7 +590,14 @@ def dependency_signature(args, root, files): pass value = [imported_modules(files), declarations, {key: item for key, item in vars(args).items() if key != "force"}, - {key: os.environ.get(key) for key in ("PATH", "VIRTUAL_ENV", "CC", "CFLAGS", "CPPFLAGS", "PROJECT_CTAGS_PYTHON_COMMAND", "PROJECT_CTAGS_CARGO", "PROJECT_CTAGS_SOURCES")}, + { + key: os.environ.get(key) + for key in ( + "PATH", "VIRTUAL_ENV", "CC", "CFLAGS", "CPPFLAGS", + "PROJECT_CTAGS_PYTHON_COMMAND", "PROJECT_CTAGS_CARGO", + "PROJECT_CTAGS_C3C", "C3_STDLIB", "PROJECT_CTAGS_SOURCES", + ) + }, [(str(root / name), file_stamp(root / name)) for name in (".venv", ".pixi/envs/default", ".devenv/state/venv")]] return hashlib.sha256(json.dumps(value, sort_keys=True).encode()).hexdigest() @@ -531,7 +605,6 @@ def dependency_signature(args, root, files): def refresh_cache(args, root, ctags): cache = resolved_path(args.cache_dir, root) cache.mkdir(parents=True, exist_ok=True) - # Different Emacs instances may share a cache; only the worker waits for this lock. with (cache / "lock").open("w") as lock: fcntl.flock(lock, fcntl.LOCK_EX) manifest_path = cache / "manifest.json" @@ -550,7 +623,6 @@ def refresh_cache(args, root, ctags): current = {str(path): file_stamp(path) for path in files} project_changed = incremental_tags(ctags, project_output, current, old.get("files", {}), force or old.get("project_stamp") != file_stamp(project_output)) - # Publish project readiness before slower dependency discovery finishes. print(json.dumps({"event": "project", "changed": project_changed}), flush=True) signature = dependency_signature(args, root, files) resolve = force or old.get("dependency_signature") != signature or time.time() - old.get("dependency_checked", 0) >= args.dependency_check_interval @@ -565,6 +637,7 @@ def refresh_cache(args, root, ctags): if not args.no_c_deps: dependency_files.extend(c_dependency_files(root, files)) dependency_files.extend(extra_source_files(args, root)) + dependency_files.extend(c3_dependency_files(args, root, files)) dependencies = {str(path): file_stamp(path) for path in sorted(set(dependency_files)) if str(path) not in current} checked = time.time() else: @@ -618,7 +691,10 @@ def main(): if not args.no_c_deps: c_headers = c_dependency_files(root, local_files) extra_files = extra_source_files(args, root) - all_files = sorted(set(local_files + python_files + rust_files + c_headers + extra_files)) + c3_files = c3_dependency_files(args, root, local_files) + all_files = sorted( + set(local_files + python_files + rust_files + c_headers + c3_files + extra_files) + ) if not all_files: raise SystemExit("No source files found") @@ -632,6 +708,8 @@ def main(): print(f"rust: {cargo}; {len(rust_files)} dependency files") if c_headers: print(f"c: {len(c_headers)} dependency headers") + if c3_files: + print(f"c3: {len(c3_files)} standard-library files") if extra_files: print(f"extra: {len(extra_files)} files") print(f"tags: {output}") @@ -25,8 +25,10 @@ (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 nil + "Per-host opacity for the entire frame, or nil to keep foreground elements opaque.") (defvar cashmere/frame-alpha-background nil - "Per-host frame opacity, or nil for the Emacs default.") + "Per-host background-only opacity, or nil for the Emacs default.") (defvar cashmere/font-family "Maple Mono NF" "Per-host default monospace font family.") (defvar cashmere/font-height 180 @@ -35,15 +37,20 @@ Set per-host in the gitignored `local.el'.") "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)) +;; 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. Whole-frame opacity takes precedence because combining both alpha modes would dim the frame twice. +(cond + (cashmere/frame-alpha + (add-to-list 'default-frame-alist '(alpha-background . 100)) + (add-to-list 'default-frame-alist `(alpha . ,cashmere/frame-alpha)) (when (display-graphic-p) - (set-frame-parameter nil 'alpha-background - cashmere/frame-alpha-background))) + (set-frame-parameter nil 'alpha-background 100) + (set-frame-parameter nil 'alpha cashmere/frame-alpha))) + (cashmere/frame-alpha-background + (add-to-list 'default-frame-alist '(alpha . 100)) + (add-to-list 'default-frame-alist `(alpha-background . ,cashmere/frame-alpha-background)) + (when (display-graphic-p) + (set-frame-parameter nil 'alpha 100) + (set-frame-parameter nil 'alpha-background cashmere/frame-alpha-background)))) (when cashmere/theme (add-to-list 'custom-theme-load-path @@ -2171,7 +2178,7 @@ Timers that expired while Emacs was closed fire immediately." :demand t :hook (after-init . global-company-mode) :custom - (company-idle-delay 0.1) + (company-idle-delay 0.25) (company-minimum-prefix-length 2) (company-require-match nil) (company-insertion-on-trigger nil) @@ -2182,32 +2189,51 @@ Timers that expired while Emacs was closed fire immediately." (company-frontends '(my/company-popup-frontend company-echo-metadata-frontend)) :config (require 'company-childframe) - (defun my/company-popup-frontend (command) - "Use an aligned child frame in graphical Emacs and an overlay in terminals." - (cond - ((eq command 'hide) - (company-childframe-hide) - (company-pseudo-tooltip-hide)) - ((display-graphic-p) - (company-childframe-frontend command)) - (t - (company-pseudo-tooltip-frontend command)))) - (setq company-selection-default 0) - (defun my/company-abort-and-normal-state () - "Close completion and leave Evil insert state." - (interactive) - (company-abort) - (when (bound-and-true-p evil-local-mode) - (evil-normal-state))) - (defun my/company-navigation-keys (&rest _) - "Keep completion navigation consistent after Evil Collection loads." - (dolist (key '("TAB" "<tab>" "C-n" "C-j")) - (keymap-set company-active-map key #'company-select-next)) - (dolist (key '("<backtab>" "S-TAB" "C-p" "C-k")) - (keymap-set company-active-map key #'company-select-previous)) - (keymap-set company-active-map "RET" #'company-complete-selection) - (keymap-set company-active-map "<return>" #'company-complete-selection) - (keymap-set company-active-map "<escape>" #'my/company-abort-and-normal-state)) + (setq company-selection-default 0)) + +(defun my/company-popup-frontend (command) + "Use an aligned child frame in graphical Emacs and an overlay in terminals." + (cond + ((eq command 'hide) + (company-childframe-hide) + (company-pseudo-tooltip-hide)) + ((display-graphic-p) + (company-childframe-frontend command)) + (t + (company-pseudo-tooltip-frontend command)))) + +(defun my/company-abort-and-normal-state () + "Close completion and leave Evil insert state." + (interactive) + (company-abort) + (when (bound-and-true-p evil-local-mode) + (evil-normal-state))) + +(defun my/company-tab () + "Indent programming buffers or advance an active snippet; otherwise select a candidate." + (interactive) + (if (derived-mode-p 'prog-mode) + (progn + (company-abort) + (if (and (bound-and-true-p yas-minor-mode) + (yas-active-snippets)) + (yas-next-field) + (indent-for-tab-command))) + (company-select-next))) + +(defun my/company-navigation-keys (&rest _) + "Keep completion navigation consistent after Evil Collection loads." + (dolist (key '("TAB" "<tab>")) + (keymap-set company-active-map key #'my/company-tab)) + (dolist (key '("C-n" "C-j")) + (keymap-set company-active-map key #'company-select-next)) + (dolist (key '("<backtab>" "S-TAB" "C-p" "C-k")) + (keymap-set company-active-map key #'company-select-previous)) + (keymap-set company-active-map "RET" #'company-complete-selection) + (keymap-set company-active-map "<return>" #'company-complete-selection) + (keymap-set company-active-map "<escape>" #'my/company-abort-and-normal-state)) + +(with-eval-after-load 'company (my/company-navigation-keys) (add-hook 'evil-collection-setup-hook #'my/company-navigation-keys)) @@ -2334,6 +2360,12 @@ Timers that expired while Emacs was closed fire immediately." :custom (nov-text-width 100)) +(defun my/programming-indent-setup () + "Use TAB to indent programming buffers without starting completion." + (setq-local tab-always-indent t)) + +(add-hook 'prog-mode-hook #'my/programming-indent-setup) + (use-package typst-ts-mode :ensure t :mode "\\.typ\\'") @@ -2351,6 +2383,11 @@ Timers that expired while Emacs was closed fire immediately." :config (yas-reload-all)) +(defun my/yas-tab-filter (command) + "Offer Yasnippet expansion through TAB outside programming buffers." + (unless (derived-mode-p 'prog-mode) + (yas-maybe-expand-abbrev-key-filter command))) + (use-package nix-ts-mode :ensure t :mode "\\.nix\\'" @@ -2389,6 +2426,23 @@ Timers that expired while Emacs was closed fire immediately." (c-ts-mode-indent-offset 2) (c-ts-mode-indent-style 'k&r)) +(use-package c3-ts-mode + :ensure (:host github :repo "c3lang/c3-ts-mode" + :ref "d6ad0e39351d4a5430e731d05474a064dcdb2bc6" + :files ("c3-ts-mode.el")) + :mode "\\.c3[it]?\\'" + :init + (with-eval-after-load 'treesit + (setf (alist-get 'c3 treesit-language-source-alist) + '("https://github.com/c3lang/tree-sitter-c3" + :commit "56d73880751a3f442296d7042e7f0a3d21967238"))) + :custom + (c3-ts-mode-indent-offset 2) + (c3-ts-mode-highlight-variable t) + (c3-ts-mode-highlight-property t) + (c3-ts-mode-highlight-assignment t) + (c3-ts-mode-highlight-punctuation t)) + (use-package rust-ts-mode :ensure nil :mode "\\.rs\\'" @@ -2505,7 +2559,8 @@ BODY is the xonsh script. PARAMS may include :dir and :cmdline." (use-package diff-hl :ensure t :hook (((prog-mode text-mode conf-mode) . diff-hl-mode) - (magit-post-refresh . diff-hl-magit-post-refresh)) + (magit-post-refresh . diff-hl-magit-post-refresh) + (fossil-ui-post-refresh . fossil-ui-diff-hl-refresh)) :custom (diff-hl-margin-symbols-alist '((insert . "┃") (delete . "▁") (change . "┃") @@ -2548,35 +2603,6 @@ BODY is the xonsh script. PARAMS may include :dir and :cmdline." (lambda (window buffer bury-or-kill) (string-match-p "\\*magit" (buffer-name buffer)))) -(defcustom my/auto-git-add-exclude-regexps - '("/\\.git/" "/node_modules/" "/\\.direnv/" "/straight/" "/elpaca/" - "\\.gpg\\'" "/\\.cache/" "/__pycache__/") - "Paths matching these regexps are skipped by `my/auto-git-add-new-file'." - :type '(repeat regexp) - :group 'my) - -(defun my/auto-git-add-new-file () - "Stage newly created file with intent-to-add so magit shows diffs. -Runs on `after-save-hook'. Only acts when the saved file is inside a -git project and currently untracked. Uses `git add -N' (intent-to-add) -so the working-tree diff stays visible until the user explicitly stages." - (let ((file buffer-file-name)) - (when (and file - (file-exists-p file) - (not (seq-some (lambda (re) (string-match-p re file)) - my/auto-git-add-exclude-regexps)) - (locate-dominating-file file ".git")) - (let ((default-directory (file-name-directory file))) - (when (and (zerop (call-process "git" nil nil nil "rev-parse" "--is-inside-work-tree")) - ;; ls-files --error-unmatch exits non-zero if untracked - (not (zerop (call-process "git" nil nil nil - "ls-files" "--error-unmatch" file)))) - (call-process "git" nil nil nil "add" "-N" file) - (when (fboundp 'magit-refresh) - (magit-refresh)) - (message "auto-staged (intent-to-add): %s" (file-name-nondirectory file))))))) - -(add-hook 'after-save-hook #'my/auto-git-add-new-file) (defun my/magit-uncommit () "Undo the last commit, leaving its changes in the working tree, unstaged." @@ -2975,12 +3001,7 @@ so the working-tree diff stays visible until the user explicitly stages." croc-ui-send-text croc-ui-receive)) (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)) + :ensure (:host github :repo "yibie/textui" :ref "v0.8.0" :files ("*.el"))) (use-package bbs-ui :ensure nil @@ -2992,6 +3013,31 @@ so the working-tree diff stays visible until the user explicitly stages." (bbs-ui-web-base-url "https://bbs.copland.systems") (bbs-ui-pull-on-open nil)) +(use-package fossil-ui + :ensure nil + :demand t + :after textui + :commands (fossil-ui fossil-ui-status) + :hook (fossil-ui-diff-mode . visual-line-mode) + :custom + (fossil-ui-title-alignment 'center) + (fossil-ui-text-wrap 'greedy) + (fossil-ui-preview-lines 20) + (fossil-ui-diff-renderer 'auto) + (fossil-ui-stage-directory (expand-file-name "fossil-stage/" user-emacs-directory)) + (fossil-ui-max-stage-bytes (* 5 1024 1024)) + (fossil-ui-keyed-timeline t) + (fossil-ui-full-frame t) + (fossil-ui-confirm-revert t) + (fossil-ui-compact-layout t) + :config + (with-eval-after-load 'zoom + (dolist (mode '(fossil-ui-mode fossil-ui-diff-mode)) + (add-to-list 'zoom-ignored-major-modes mode))) + (with-eval-after-load 'golden-ratio + (dolist (mode '(fossil-ui-mode fossil-ui-diff-mode)) + (add-to-list 'golden-ratio-exclude-modes mode)))) + (use-package yggdrasil-ui :ensure nil :after textui @@ -3097,6 +3143,25 @@ This function records the time when `window-setup-hook' runs." projectile-globally-ignored-buffers '("\\*magit.*")) (add-hook 'after-save-hook #'projectile-cache-current-file)) +(defun my/projectile-fossil-command (original vcs &optional directory) + "Return a Fossil listing relative to DIRECTORY, delegating other VCS to ORIGINAL." + (if (not (eq vcs 'fossil)) + (funcall original vcs directory) + (let* ((directory (file-name-as-directory + (expand-file-name (or directory default-directory)))) + (checkout (or (locate-dominating-file directory ".fslckout") + (locate-dominating-file directory "_FOSSIL_") + (user-error "No Fossil checkout for %s" directory))) + (prefix (if (file-equal-p directory checkout) + "" + (file-relative-name directory checkout)))) + (format "fossil ls . | cut -b %d- | tr '\\n' '\\0'" + (1+ (string-bytes prefix)))))) + +(with-eval-after-load 'projectile + (advice-add 'projectile-get-ext-command :around + #'my/projectile-fossil-command)) + (defun my/projectile-dashboard-fullscreen () "Show the Projectile dashboard in the full frame." (interactive) @@ -3818,6 +3883,10 @@ place. `C-c C-c' commits, `C-c C-k' aborts." (kbd "N") #'my/evil-move-visual-lines-down (kbd "P") #'my/evil-move-visual-lines-up) +(with-eval-after-load 'yasnippet + (define-key yas-minor-mode-map (kbd "TAB") + '(menu-item "" yas-expand :filter my/yas-tab-filter))) + (with-eval-after-load 'compile (keymap-set compilation-mode-map "C-c o" #'nix-compile-goto-option)) @@ -3962,6 +4031,47 @@ place. `C-c C-c' commits, `C-c C-k' aborts." (kbd "f") #'link-hint-open-link (kbd "F") #'link-hint-copy-link)) +(with-eval-after-load 'fossil-ui + (evil-define-key '(normal motion visual) fossil-ui-mode-map + (kbd "SPC") my/leader-map + (kbd "V") #'evil-visual-line + (kbd "s") #'fossil-ui-stage + (kbd "u") #'fossil-ui-unstage + (kbd "r") #'fossil-ui-refresh + (kbd "x") #'fossil-ui-discard + (kbd "d") #'fossil-ui-delete + (kbd "G") #'evil-goto-line + (kbd "TAB") #'fossil-ui-diff + (kbd "<tab>") #'fossil-ui-diff + (kbd "c") nil + (kbd "c c") #'fossil-ui-commit + (kbd "S") #'fossil-ui-sync + (kbd "F") #'fossil-ui-update + (kbd "RET") #'fossil-ui-visit-file + (kbd "<return>") #'fossil-ui-visit-file + (kbd "D") #'fossil-ui-staged-diff + (kbd "q") #'fossil-ui-quit + (kbd "?") #'fossil-ui-help) + (evil-define-key '(normal motion visual) fossil-ui-diff-mode-map + (kbd "SPC") my/leader-map + (kbd "V") #'evil-visual-line + (kbd "G") #'evil-goto-line + (kbd "s") #'fossil-ui-stage + (kbd "u") #'fossil-ui-unstage + (kbd "x") #'fossil-ui-discard + (kbd "r") #'fossil-ui-diff-refresh + (kbd "D") #'fossil-ui-diff-toggle + (kbd "q") #'fossil-ui-quit) + (evil-define-key 'visual fossil-ui-mode-map + (kbd "j") #'evil-next-line + (kbd "k") #'evil-previous-line) + (evil-define-key 'visual fossil-ui-diff-mode-map + (kbd "j") #'evil-next-line + (kbd "k") #'evil-previous-line) + (evil-define-key '(normal insert visual motion) fossil-ui-commit-mode-map + (kbd "C-c C-c") #'fossil-ui-commit-submit + (kbd "C-c C-k") #'fossil-ui-commit-cancel)) + (with-eval-after-load 'ghostel (evil-define-key 'normal ghostel-mode-map (kbd "g t") #'ghostel-next @@ -37,7 +37,8 @@ (setq my/local-packages '((kitty-graphics . "~/code/kitty-graphics"))) -(setq cashmere/frame-alpha-background 100 +(setq cashmere/frame-alpha 100 + cashmere/frame-alpha-background nil cashmere/font-family "SFMono Nerd Font" cashmere/font-height 180 cashmere/theme 'tinty) @@ -48,8 +49,10 @@ (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 nil + "Per-host opacity for the entire frame, or nil to keep foreground elements opaque.") (defvar cashmere/frame-alpha-background nil - "Per-host frame opacity, or nil for the Emacs default.") + "Per-host background-only opacity, or nil for the Emacs default.") (defvar cashmere/font-family "Maple Mono NF" "Per-host default monospace font family.") (defvar cashmere/font-height 180 @@ -58,15 +61,20 @@ Set per-host in the gitignored `local.el'.") "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)) +;; 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. Whole-frame opacity takes precedence because combining both alpha modes would dim the frame twice. +(cond + (cashmere/frame-alpha + (add-to-list 'default-frame-alist '(alpha-background . 100)) + (add-to-list 'default-frame-alist `(alpha . ,cashmere/frame-alpha)) (when (display-graphic-p) - (set-frame-parameter nil 'alpha-background - cashmere/frame-alpha-background))) + (set-frame-parameter nil 'alpha-background 100) + (set-frame-parameter nil 'alpha cashmere/frame-alpha))) + (cashmere/frame-alpha-background + (add-to-list 'default-frame-alist '(alpha . 100)) + (add-to-list 'default-frame-alist `(alpha-background . ,cashmere/frame-alpha-background)) + (when (display-graphic-p) + (set-frame-parameter nil 'alpha 100) + (set-frame-parameter nil 'alpha-background cashmere/frame-alpha-background)))) (when cashmere/theme (add-to-list 'custom-theme-load-path @@ -2548,13 +2556,13 @@ Auto switch silos (different workspaces/folders) based on preconfigured director * company-mode -#+begin_src emacs-lisp :tangle yes +#+begin_src emacs-lisp (use-package company :ensure t :demand t :hook (after-init . global-company-mode) :custom - (company-idle-delay 0.1) + (company-idle-delay 0.25) (company-minimum-prefix-length 2) (company-require-match nil) (company-insertion-on-trigger nil) @@ -2565,32 +2573,67 @@ Auto switch silos (different workspaces/folders) based on preconfigured director (company-frontends '(my/company-popup-frontend company-echo-metadata-frontend)) :config (require 'company-childframe) - (defun my/company-popup-frontend (command) - "Use an aligned child frame in graphical Emacs and an overlay in terminals." - (cond - ((eq command 'hide) - (company-childframe-hide) - (company-pseudo-tooltip-hide)) - ((display-graphic-p) - (company-childframe-frontend command)) - (t - (company-pseudo-tooltip-frontend command)))) - (setq company-selection-default 0) - (defun my/company-abort-and-normal-state () - "Close completion and leave Evil insert state." - (interactive) - (company-abort) - (when (bound-and-true-p evil-local-mode) - (evil-normal-state))) - (defun my/company-navigation-keys (&rest _) - "Keep completion navigation consistent after Evil Collection loads." - (dolist (key '("TAB" "<tab>" "C-n" "C-j")) - (keymap-set company-active-map key #'company-select-next)) - (dolist (key '("<backtab>" "S-TAB" "C-p" "C-k")) - (keymap-set company-active-map key #'company-select-previous)) - (keymap-set company-active-map "RET" #'company-complete-selection) - (keymap-set company-active-map "<return>" #'company-complete-selection) - (keymap-set company-active-map "<escape>" #'my/company-abort-and-normal-state)) + (setq company-selection-default 0)) +#+end_src + +** company-popup-frontend + +#+begin_src emacs-lisp +(defun my/company-popup-frontend (command) + "Use an aligned child frame in graphical Emacs and an overlay in terminals." + (cond + ((eq command 'hide) + (company-childframe-hide) + (company-pseudo-tooltip-hide)) + ((display-graphic-p) + (company-childframe-frontend command)) + (t + (company-pseudo-tooltip-frontend command)))) +#+end_src + +** company-abort-and-normal-state + +#+begin_src emacs-lisp +(defun my/company-abort-and-normal-state () + "Close completion and leave Evil insert state." + (interactive) + (company-abort) + (when (bound-and-true-p evil-local-mode) + (evil-normal-state))) +#+end_src + +** company-tab + +#+begin_src emacs-lisp +(defun my/company-tab () + "Indent programming buffers or advance an active snippet; otherwise select a candidate." + (interactive) + (if (derived-mode-p 'prog-mode) + (progn + (company-abort) + (if (and (bound-and-true-p yas-minor-mode) + (yas-active-snippets)) + (yas-next-field) + (indent-for-tab-command))) + (company-select-next))) +#+end_src + +** company-navigation-keys + +#+begin_src emacs-lisp +(defun my/company-navigation-keys (&rest _) + "Keep completion navigation consistent after Evil Collection loads." + (dolist (key '("TAB" "<tab>")) + (keymap-set company-active-map key #'my/company-tab)) + (dolist (key '("C-n" "C-j")) + (keymap-set company-active-map key #'company-select-next)) + (dolist (key '("<backtab>" "S-TAB" "C-p" "C-k")) + (keymap-set company-active-map key #'company-select-previous)) + (keymap-set company-active-map "RET" #'company-complete-selection) + (keymap-set company-active-map "<return>" #'company-complete-selection) + (keymap-set company-active-map "<escape>" #'my/company-abort-and-normal-state)) + +(with-eval-after-load 'company (my/company-navigation-keys) (add-hook 'evil-collection-setup-hook #'my/company-navigation-keys)) #+end_src @@ -2628,24 +2671,6 @@ Auto switch silos (different workspaces/folders) based on preconfigured director (add-hook 'completion-at-point-functions #'cape-file)) #+end_src -* COMMENT embark - -#+begin_src emacs-lisp -(use-package embark - :ensure (:wait t) - :defer t - :bind - (("C-." . embark-act) - ("M-." . embark-dwim) - ("C-h B" . embark-bindings) - :map minibuffer-local-map - ("C-c C-a" . embark-act-all) - ("C-c C-e" . embark-export) - ("C-c C-o" . embark-collect)) - :init - (setq prefix-help-command #'embark-prefix-help-command)) -#+end_src - * helm-mode #+begin_src emacs-lisp @@ -2761,6 +2786,16 @@ Auto switch silos (different workspaces/folders) based on preconfigured director #+end_src * programming +** programming-indent-setup + +#+begin_src emacs-lisp +(defun my/programming-indent-setup () + "Use TAB to indent programming buffers without starting completion." + (setq-local tab-always-indent t)) + +(add-hook 'prog-mode-hook #'my/programming-indent-setup) +#+end_src + ** typst-mode #+begin_src emacs-lisp @@ -2786,6 +2821,15 @@ Auto switch silos (different workspaces/folders) based on preconfigured director (yas-reload-all)) #+end_src +*** yas-tab-filter + +#+begin_src emacs-lisp +(defun my/yas-tab-filter (command) + "Offer Yasnippet expansion through TAB outside programming buffers." + (unless (derived-mode-p 'prog-mode) + (yas-maybe-expand-abbrev-key-filter command))) +#+end_src + ** nix-ts-mode #+begin_src emacs-lisp @@ -2839,6 +2883,27 @@ Built-in tree-sitter mode (Emacs 29+). The =c= grammar ships via =treesit-gramma (c-ts-mode-indent-style 'k&r)) #+end_src +** c3-ts-mode + +#+begin_src emacs-lisp +(use-package c3-ts-mode + :ensure (:host github :repo "c3lang/c3-ts-mode" + :ref "d6ad0e39351d4a5430e731d05474a064dcdb2bc6" + :files ("c3-ts-mode.el")) + :mode "\\.c3[it]?\\'" + :init + (with-eval-after-load 'treesit + (setf (alist-get 'c3 treesit-language-source-alist) + '("https://github.com/c3lang/tree-sitter-c3" + :commit "56d73880751a3f442296d7042e7f0a3d21967238"))) + :custom + (c3-ts-mode-indent-offset 2) + (c3-ts-mode-highlight-variable t) + (c3-ts-mode-highlight-property t) + (c3-ts-mode-highlight-assignment t) + (c3-ts-mode-highlight-punctuation t)) +#+end_src + ** rust-ts-mode #+begin_src emacs-lisp @@ -3036,7 +3101,8 @@ BODY is the xonsh script. PARAMS may include :dir and :cmdline." (use-package diff-hl :ensure t :hook (((prog-mode text-mode conf-mode) . diff-hl-mode) - (magit-post-refresh . diff-hl-magit-post-refresh)) + (magit-post-refresh . diff-hl-magit-post-refresh) + (fossil-ui-post-refresh . fossil-ui-diff-hl-refresh)) :custom (diff-hl-margin-symbols-alist '((insert . "┃") (delete . "▁") (change . "┃") @@ -3087,35 +3153,6 @@ BODY is the xonsh script. PARAMS may include :dir and :cmdline." (lambda (window buffer bury-or-kill) (string-match-p "\\*magit" (buffer-name buffer)))) -(defcustom my/auto-git-add-exclude-regexps - '("/\\.git/" "/node_modules/" "/\\.direnv/" "/straight/" "/elpaca/" - "\\.gpg\\'" "/\\.cache/" "/__pycache__/") - "Paths matching these regexps are skipped by `my/auto-git-add-new-file'." - :type '(repeat regexp) - :group 'my) - -(defun my/auto-git-add-new-file () - "Stage newly created file with intent-to-add so magit shows diffs. -Runs on `after-save-hook'. Only acts when the saved file is inside a -git project and currently untracked. Uses `git add -N' (intent-to-add) -so the working-tree diff stays visible until the user explicitly stages." - (let ((file buffer-file-name)) - (when (and file - (file-exists-p file) - (not (seq-some (lambda (re) (string-match-p re file)) - my/auto-git-add-exclude-regexps)) - (locate-dominating-file file ".git")) - (let ((default-directory (file-name-directory file))) - (when (and (zerop (call-process "git" nil nil nil "rev-parse" "--is-inside-work-tree")) - ;; ls-files --error-unmatch exits non-zero if untracked - (not (zerop (call-process "git" nil nil nil - "ls-files" "--error-unmatch" file)))) - (call-process "git" nil nil nil "add" "-N" file) - (when (fboundp 'magit-refresh) - (magit-refresh)) - (message "auto-staged (intent-to-add): %s" (file-name-nondirectory file))))))) - -(add-hook 'after-save-hook #'my/auto-git-add-new-file) (defun my/magit-uncommit () "Undo the last commit, leaving its changes in the working tree, unstaged." @@ -3647,13 +3684,12 @@ moved to local.el #+begin_src emacs-lisp (use-package textui - :ensure (:host github :repo "yibie/textui" :files ("*.el"))) + :ensure (:host github :repo "yibie/textui" :ref "v0.8.0" :files ("*.el"))) +#+end_src -(use-package fossil-ui - :ensure nil - :after textui - :commands (fossil-ui fossil-ui-status)) +* bbs-ui +#+begin_src emacs-lisp (use-package bbs-ui :ensure nil :after textui @@ -3663,7 +3699,40 @@ moved to local.el (expand-file-name "bbs-sandbox.fossil" "/home/cashmere/bbs/")) (bbs-ui-web-base-url "https://bbs.copland.systems") (bbs-ui-pull-on-open nil)) +#+end_src + +* fossil-ui +#+begin_src emacs-lisp +(use-package fossil-ui + :ensure nil + :demand t + :after textui + :commands (fossil-ui fossil-ui-status) + :hook (fossil-ui-diff-mode . visual-line-mode) + :custom + (fossil-ui-title-alignment 'center) + (fossil-ui-text-wrap 'greedy) + (fossil-ui-preview-lines 20) + (fossil-ui-diff-renderer 'auto) + (fossil-ui-stage-directory (expand-file-name "fossil-stage/" user-emacs-directory)) + (fossil-ui-max-stage-bytes (* 5 1024 1024)) + (fossil-ui-keyed-timeline t) + (fossil-ui-full-frame t) + (fossil-ui-confirm-revert t) + (fossil-ui-compact-layout t) + :config + (with-eval-after-load 'zoom + (dolist (mode '(fossil-ui-mode fossil-ui-diff-mode)) + (add-to-list 'zoom-ignored-major-modes mode))) + (with-eval-after-load 'golden-ratio + (dolist (mode '(fossil-ui-mode fossil-ui-diff-mode)) + (add-to-list 'golden-ratio-exclude-modes mode)))) +#+end_src + +* yggdrasil-ui + +#+begin_src emacs-lisp (use-package yggdrasil-ui :ensure nil :after textui @@ -3791,7 +3860,34 @@ This function records the time when `window-setup-hook' runs." projectile-require-project-root nil projectile-globally-ignored-buffers '("\\*magit.*")) (add-hook 'after-save-hook #'projectile-cache-current-file)) +#+end_src + +** projectile-fossil-command +#+begin_src emacs-lisp +(defun my/projectile-fossil-command (original vcs &optional directory) + "Return a Fossil listing relative to DIRECTORY, delegating other VCS to ORIGINAL." + (if (not (eq vcs 'fossil)) + (funcall original vcs directory) + (let* ((directory (file-name-as-directory + (expand-file-name (or directory default-directory)))) + (checkout (or (locate-dominating-file directory ".fslckout") + (locate-dominating-file directory "_FOSSIL_") + (user-error "No Fossil checkout for %s" directory))) + (prefix (if (file-equal-p directory checkout) + "" + (file-relative-name directory checkout)))) + (format "fossil ls . | cut -b %d- | tr '\\n' '\\0'" + (1+ (string-bytes prefix)))))) + +(with-eval-after-load 'projectile + (advice-add 'projectile-get-ext-command :around + #'my/projectile-fossil-command)) +#+end_src + +** projectile-dashboard-fullscreen + +#+begin_src emacs-lisp (defun my/projectile-dashboard-fullscreen () "Show the Projectile dashboard in the full frame." (interactive) @@ -4573,6 +4669,14 @@ place. `C-c C-c' commits, `C-c C-k' aborts." (kbd "P") #'my/evil-move-visual-lines-up) #+end_src +** yasnippet-mode + +#+begin_src emacs-lisp +(with-eval-after-load 'yasnippet + (define-key yas-minor-mode-map (kbd "TAB") + '(menu-item "" yas-expand :filter my/yas-tab-filter))) +#+end_src + ** compilation-mode #+begin_src emacs-lisp @@ -4749,6 +4853,51 @@ place. `C-c C-c' commits, `C-c C-k' aborts." (kbd "F") #'link-hint-copy-link)) #+end_src +** fossil-ui-mode + +#+begin_src emacs-lisp +(with-eval-after-load 'fossil-ui + (evil-define-key '(normal motion visual) fossil-ui-mode-map + (kbd "SPC") my/leader-map + (kbd "V") #'evil-visual-line + (kbd "s") #'fossil-ui-stage + (kbd "u") #'fossil-ui-unstage + (kbd "r") #'fossil-ui-refresh + (kbd "x") #'fossil-ui-discard + (kbd "d") #'fossil-ui-delete + (kbd "G") #'evil-goto-line + (kbd "TAB") #'fossil-ui-diff + (kbd "<tab>") #'fossil-ui-diff + (kbd "c") nil + (kbd "c c") #'fossil-ui-commit + (kbd "S") #'fossil-ui-sync + (kbd "F") #'fossil-ui-update + (kbd "RET") #'fossil-ui-visit-file + (kbd "<return>") #'fossil-ui-visit-file + (kbd "D") #'fossil-ui-staged-diff + (kbd "q") #'fossil-ui-quit + (kbd "?") #'fossil-ui-help) + (evil-define-key '(normal motion visual) fossil-ui-diff-mode-map + (kbd "SPC") my/leader-map + (kbd "V") #'evil-visual-line + (kbd "G") #'evil-goto-line + (kbd "s") #'fossil-ui-stage + (kbd "u") #'fossil-ui-unstage + (kbd "x") #'fossil-ui-discard + (kbd "r") #'fossil-ui-diff-refresh + (kbd "D") #'fossil-ui-diff-toggle + (kbd "q") #'fossil-ui-quit) + (evil-define-key 'visual fossil-ui-mode-map + (kbd "j") #'evil-next-line + (kbd "k") #'evil-previous-line) + (evil-define-key 'visual fossil-ui-diff-mode-map + (kbd "j") #'evil-next-line + (kbd "k") #'evil-previous-line) + (evil-define-key '(normal insert visual motion) fossil-ui-commit-mode-map + (kbd "C-c C-c") #'fossil-ui-commit-submit + (kbd "C-c C-k") #'fossil-ui-commit-cancel)) +#+end_src + ** ghostel-mode #+begin_src emacs-lisp diff --git a/elpaca-lock.eld b/elpaca-lock.eld index 1cc5420..2ee16c4 100644 --- a/elpaca-lock.eld +++ b/elpaca-lock.eld @@ -107,6 +107,12 @@ :repo "ahyatt/emacs-bluesky" :type git :protocol https :inherit t :depth treeless :ref "b4b7957a3af0533918535486f44afcb808d38d24")) + (c3-ts-mode :source "elpaca-menu-lock-file" :recipe + (:source nil :package "c3-ts-mode" :id c3-ts-mode :host + github :repo "c3lang/c3-ts-mode" :ref + "d6ad0e39351d4a5430e731d05474a064dcdb2bc6" + :files ("c3-ts-mode.el") :type git :protocol + https :inherit t :depth treeless)) (cape :source "elpaca-menu-lock-file" :recipe (:package "cape" :repo "minad/cape" :fetcher github :files ("*.el" "*.el.in" "dir" "*.info" "*.texi" "*.texinfo" @@ -1399,7 +1405,7 @@ (:source nil :package "textui" :id textui :host github :repo "yibie/textui" :files ("*.el") :type git :protocol https :inherit t :depth treeless :ref - "f6b3a06b95d80e2a2122d38c13d0df94bdf4df85")) + "ce37202ec910e03008bd50472b2df1217b5f1a7e")) (tldr :source "elpaca-menu-lock-file" :recipe (:package "tldr" :fetcher github :repo "kuanyui/tldr.el" :files ("*.el" "*.el.in" "dir" "*.info" "*.texi" "*.texinfo" diff --git a/lisp/fossil-ui.el b/lisp/fossil-ui.el index 0305d3a..0e65337 100644 --- a/lisp/fossil-ui.el +++ b/lisp/fossil-ui.el @@ -3,49 +3,85 @@ ;; Copyright (C) 2026 cashmere ;; Author: cashmere -;; Version: 0.1.0 -;; Package-Requires: ((emacs "29.1") (textui "0.5.1")) +;; Version: 0.2.0 +;; Package-Requires: ((emacs "29.1") (textui "0.8.0")) ;; 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. +;; Fossil dashboard with persistent local staging, partial commits, and recovery. ;;; Code: (require 'ansi-color) (require 'cl-lib) +(declare-function evil-make-overriding-map "evil-core" (keymap &optional state copy)) +(require 'textui-keyed-region) (require 'diff-mode) (require 'json) (require 'outline) (require 'seq) (require 'subr-x) +(require 'text-property-search) +(require 'vc) (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) +(declare-function evil-visual-range "evil-states" ()) +(declare-function evil-exit-visual-state "evil-states" ()) +(declare-function diff-hl-update "diff-hl" ()) +(declare-function diff-hl-remove-overlays "diff-hl" ()) (defgroup fossil-ui nil "A compact TextUI frontend for Fossil." :group 'tools :prefix "fossil-ui-") +(defvar fossil-ui-post-refresh-hook nil + "Hook run in the dashboard after a successful checkout refresh.") + (defcustom fossil-ui-program "fossil" "Fossil executable used by the dashboard." :type 'string :group 'fossil-ui) +(defcustom fossil-ui-stage-directory (expand-file-name "fossil-stage/" user-emacs-directory) + "Private local staging snapshots and interrupted-commit recovery files." + :type 'directory + :group 'fossil-ui) + +(defcustom fossil-ui-max-stage-bytes (* 5 1024 1024) + "Maximum text file size accepted for partial staging." + :type 'integer + :group 'fossil-ui) + +(defcustom fossil-ui-full-frame t + "Open Fossil using the entire Emacs frame." + :type 'boolean + :group 'fossil-ui) + +(defcustom fossil-ui-confirm-revert t + "Confirm before discarding selected working changes." + :type 'boolean + :group 'fossil-ui) + +(defcustom fossil-ui-compact-layout t + "Keep dashboard cards compact so changes and recent commits fit together." + :type 'boolean + :group 'fossil-ui) + +(defcustom fossil-ui-keyed-timeline t + "Reconcile timeline entries using TextUI's stable keyed regions." + :type 'boolean + :group 'fossil-ui) + +(defvar-local fossil-ui-window-configuration nil) +(defvar-local fossil-ui-diff-context nil) +(defvar-local fossil-ui-commit-index nil) + (defcustom fossil-ui-timeline-limit 25 "Maximum number of recent check-ins loaded for the dashboard." :type 'integer @@ -93,6 +129,113 @@ runs an external renderer." :type '(repeat string) :group 'fossil-ui) +(defcustom fossil-ui-title-alignment 'center + "TextUI alignment of the project heading." + :type '(choice (const left) (const center) (const right)) + :group 'fossil-ui) + +(defcustom fossil-ui-text-wrap 'greedy + "TextUI line-breaking strategy for commit messages and status banners." + :type '(choice (const greedy) (const balanced)) + :group 'fossil-ui) + +(defcustom fossil-ui-preview-lines 20 + "Maximum number of diff lines shown in the inline preview." + :type '(integer 1 *) + :group 'fossil-ui) + +(defun fossil-ui--text (value &optional face align) + "Return wrapping TextUI text for VALUE with FACE and ALIGN." + `(:type :text + :value ,(if face + (propertize value 'face face) + value) + :align ,(or align 'left) + :wrap ,fossil-ui-text-wrap)) + +(defun fossil-ui--preview-layout (widget width) + "Lay out a read-only diff WIDGET at WIDTH without wrapping code lines." + (let* ((width + (if fossil-ui-content-width + (min width fossil-ui-content-width) + width)) + (lines (split-string (widget-get widget :value) "\n")) + (limit (max 1 fossil-ui-preview-lines)) + (visible (seq-take lines limit))) + (concat + (propertize + (fossil-ui--fit (format "Diff preview · %s · P closes" (widget-get widget :path)) width) 'face 'fossil-ui-strong) + "\n" + (mapconcat + (lambda (line) + (propertize + (truncate-string-to-width (replace-regexp-in-string "\t" " " line) width nil nil) + 'face + (cond + ((string-prefix-p "@@" line) + 'diff-hunk-header) + ((string-prefix-p "+" line) + 'diff-added) + ((string-prefix-p "-" line) + 'diff-removed) + (t 'default)))) + visible "\n") + (when (> (length lines) limit) + (concat "\n" (fossil-ui--fit "… RET on file opens the complete diff" width)))))) + +(defun fossil-ui--preview-attach (widget from to) + "Attach preview WIDGET to existing text between FROM and TO." + (widget-put widget :from (copy-marker from t)) + (widget-put widget :to (copy-marker to nil)) + (widget-put widget :delete #'widget-leave-text)) + +(define-widget 'fossil-ui-preview 'item + "A width-aware TextUI 0.8 block widget for a read-only diff preview." + :textui-layout #'fossil-ui--preview-layout + :textui-attach #'fossil-ui--preview-attach) + +(defun fossil-ui--preview-data (root path) + "Read the internal unified diff for PATH under ROOT." + (let ((output (fossil-ui--require-success root "diff" "--internal" "--unified" "--" path))) + (if (string-empty-p output) + "No textual diff available." + output))) + +(defun fossil-ui-toggle-preview () + "Toggle an inline diff preview for the tracked file at point." + (interactive) + (let ((path (fossil-ui--path-at-point)) + (previous (plist-get textui-state :preview-path))) + (if (or (and path + (equal path (plist-get textui-state :preview-path))) + (and (not path) + (plist-get textui-state :preview-path))) + (textui-update + (current-buffer) + (lambda (state) + (plist-put (plist-put state :preview-path nil) :preview nil))) + (unless path + (user-error "No file at point")) + (when (equal (fossil-ui--status-at-point) "EXTRA") + (user-error "Add the file first to preview its Fossil diff")) + (let ((diff (fossil-ui--preview-data (plist-get textui-state :root) path))) + (textui-update + (current-buffer) + (lambda (state) + (plist-put (plist-put state :preview-path path) :preview diff))))) + (textui-refresh (current-buffer)) + (if (plist-get textui-state :preview-path) + (progn + (goto-char (point-min)) + (when (re-search-forward "^Diff preview" nil t) + (beginning-of-line) + (when (eq (window-buffer) (current-buffer)) + (recenter 0)))) + (when (or path + previous) + (fossil-ui--goto-path (or path + previous)))))) + (defface fossil-ui-strong '((t :inherit bold)) "Structural text." :group 'fossil-ui) @@ -314,26 +457,34 @@ Paths may contain spaces. A dash in either count denotes binary data." (branches (alist-get 'branches payload))) (sort (copy-sequence (or branches nil)) #'string-lessp))) -(defun fossil-ui--snapshot (directory &optional selected) +(defun fossil-ui--checkout-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))) + (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") + :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) + :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)))))) + (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 @@ -424,21 +575,33 @@ When NARROW is non-nil return a primary row without trailing metadata." (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)))))) + (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))))) + :layout (:focus-id ,(list 'file path (equal status "STAGED"))) + :action ,(lambda (&rest _) + (fossil-ui-visit-file))))) (defun fossil-ui--change-elements (change width selected) "Return responsive dashboard elements for CHANGE." @@ -460,29 +623,39 @@ When NARROW is non-nil return a primary row without trailing metadata." (defun fossil-ui--timeline-elements (entry width) "Render timeline ENTRY at WIDTH as a two-line rail." - (let* ((uuid (or (alist-get 'uuid entry) "")) + (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 ""))) + (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--text (concat "● " comment)) (fossil-ui--item (fossil-ui--fit - (format "│ %s %s%s" short author - (if (string-empty-p tag-text) "" (concat " · " tag-text))) width) + (format "│ %s %s %s%s" short date author + (if (string-empty-p tag-text) + "" + (concat " · " tag-text))) + width) 'fossil-ui-faded)))) (defun fossil-ui--timeline-count () @@ -508,11 +681,18 @@ When NARROW is non-nil return a primary row without trailing metadata." (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)) + `(:type :flex + :direction :column + :gap ,(if fossil-ui-compact-layout 0 1) + :padding ,(if fossil-ui-compact-layout 0 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)) + title + (unless (get-text-property 0 'face title) + 'fossil-ui-strong)) ,(fossil-ui--column children)))) (defun fossil-ui--metadata-columns (width) @@ -619,7 +799,7 @@ MINIMUM and GROW are parent-facing Flex sizing hints." "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)) + (list (fossil-ui--text message face)) width width 0)) (defun fossil-ui--screen-elements (width) @@ -631,60 +811,83 @@ MINIMUM and GROW are parent-facing Flex sizing hints." (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))))) + (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 + (fossil-ui--text + (format "%s %s" (fossil-ui--icon 'repository) project) + 'fossil-ui-strong fossil-ui-title-alignment) + `(: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 "r" "Refresh" #'fossil-ui-refresh 'refresh) + ,(fossil-ui--keycap "c c" "Commit" #'fossil-ui-commit 'commit) + ,(fossil-ui--keycap "F" "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))) + (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))))) + (fossil-ui--item "P Diff preview · ? Help · q Close" 'fossil-ui-faded))))) (defun fossil-ui--path-at-point () - "Return the Fossil path at point." + "Return the file path anywhere on the current dashboard row." (or (get-text-property (point) 'fossil-ui-path) - (get-text-property (line-beginning-position) 'fossil-ui-path))) + (save-excursion + (goto-char (line-beginning-position)) + (let ((end (line-end-position)) + path) + (while (and (< (point) end) + (not path)) + (setq path (get-text-property (point) 'fossil-ui-path)) + (unless path + (goto-char (next-single-property-change (point) 'fossil-ui-path nil end)))) + path)))) (defun fossil-ui--status-at-point () - "Return the Fossil status at point." + "Return the Fossil status anywhere on the current dashboard row." (or (get-text-property (point) 'fossil-ui-status) - (get-text-property (line-beginning-position) 'fossil-ui-status))) + (save-excursion + (goto-char (line-beginning-position)) + (let ((end (line-end-position)) + status) + (while (and (< (point) end) + (not status)) + (setq status (get-text-property (point) 'fossil-ui-status)) + (unless status + (goto-char (next-single-property-change (point) 'fossil-ui-status nil end)))) + status)))) (defun fossil-ui--goto-path (path) "Move point to PATH when it is visible." @@ -726,34 +929,162 @@ MINIMUM and GROW are parent-facing Flex sizing hints." (goto-char target) (message "No changed files")))) +(defun fossil-ui--file-positions (staged) + "Return file positions in the STAGED or unstaged section in display order." + (save-excursion + (goto-char (point-min)) + (let (rows seen) + (while-let + ((match + (text-property-search-forward 'fossil-ui-path nil nil + t))) + (let* ((start (prop-match-beginning match)) + (path (prop-match-value match)) + (is-staged + (equal (get-text-property start 'fossil-ui-status) + "STAGED"))) + (when (and (eq is-staged staged) + (not (member path seen))) + (push path seen) + (push (cons path start) rows)))) + (nreverse rows)))) + +(defun fossil-ui--dashboard-position () + "Capture the dashboard row and its position within the visible window." + (let ((window (get-buffer-window (current-buffer)))) + (save-excursion + (when window + (goto-char (window-point window))) + (let* ((path (fossil-ui--path-at-point)) + (staged (equal (fossil-ui--status-at-point) "STAGED")) + (line (line-number-at-pos))) + (list :path path + :staged staged + :index + (and path + (cl-position path + (fossil-ui--file-positions staged) + :key #'car + :test #'equal)) + :line line + :column (current-column) + :window window + :offset (and window + (- line + (line-number-at-pos (window-start window))))))))) + +(defun fossil-ui--restore-dashboard-position (position) + "Restore POSITION without following a file into another staging section." + (let* ((rows + (and (plist-get position :path) + (fossil-ui--file-positions (plist-get position :staged)))) + (target + (or (assoc (plist-get position :path) rows) + (and rows + (nth + (min (or (plist-get position :index) + 0) + (1- (length rows))) + rows)))) + (window (plist-get position :window))) + (if target + (goto-char (cdr target)) + (goto-char (point-min)) + (forward-line (1- (plist-get position :line)))) + (move-to-column (plist-get position :column)) + (when (and (window-live-p window) + (eq (window-buffer window) (current-buffer))) + (set-window-point window (point)) + (save-excursion + (forward-line (- (or (plist-get position :offset) + 0))) + (set-window-start window (line-beginning-position) t))))) + +(defun fossil-ui--preserve-dashboard-position (original buffer &rest args) + "Keep file-list position when ORIGINAL redraws dashboard BUFFER with ARGS." + (if (not + (and (buffer-live-p buffer) + (with-current-buffer buffer + (derived-mode-p 'fossil-ui-mode)))) + (apply original buffer args) + (with-current-buffer buffer + (let ((position (fossil-ui--dashboard-position))) + (prog1 (apply original buffer args) + (fossil-ui--restore-dashboard-position position)))))) + (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)) + (let ((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))) + (let ((next (fossil-ui--snapshot root selected)) + (preview-path (plist-get textui-state :preview-path))) + (when (and preview-path + (cl-find preview-path + (plist-get next :changes) + :key (lambda (change) + (plist-get change :path)) + :test #'equal)) + (setq next (plist-put next :preview-path preview-path)) + (setq next (plist-put next :preview (fossil-ui--preview-data root preview-path)))) + (setq textui-state next) + (textui-refresh (current-buffer)) + (run-hooks 'fossil-ui-post-refresh-hook)) (error (textui-set-state (current-buffer) :error (error-message-string err)))))) +(defun fossil-ui-diff-hl-refresh () + "Refresh VC state and diff-hl in file buffers belonging to this checkout." + (when (featurep 'diff-hl) + (let ((root (plist-get textui-state :root))) + (when (and root + (not (file-remote-p root))) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (and (bound-and-true-p diff-hl-mode) + buffer-file-name + (not (file-remote-p buffer-file-name)) + (file-in-directory-p buffer-file-name root)) + (condition-case err + (progn + (when (and (file-exists-p buffer-file-name) + (not (buffer-modified-p)) + (not + (verify-visited-file-modtime (current-buffer)))) + (revert-buffer t t t)) + (vc-file-clearprops buffer-file-name) + (if (file-exists-p buffer-file-name) + (progn + (when (eq (vc-backend buffer-file-name) 'Fossil) + (vc-state-refresh buffer-file-name 'Fossil)) + (diff-hl-update)) + (diff-hl-remove-overlays))) + (error + (message "Fossil diff-hl (%s): %s" + (buffer-name) + (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"))) + (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")) + (let ((root (plist-get textui-state :root))) + (fossil-ui--clean-buffer (expand-file-name path root)) + (fossil-ui--require-success root "add" "--" path) + (fossil-ui-refresh))) (textui-update (current-buffer) (lambda (state) (let* ((next (copy-sequence state)) (selected (copy-sequence (plist-get state :selected)))) - (plist-put next :selected + (plist-put next + :selected (if (member path selected) (delete path selected) (append selected (list path))))))) @@ -792,14 +1123,24 @@ MINIMUM and GROW are parent-facing Flex sizing hints." (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) + (define-key map (kbd "q") #'fossil-ui-quit) + (define-key map (kbd "s") #'fossil-ui-stage) + (define-key map (kbd "u") #'fossil-ui-unstage) + (define-key map (kbd "x") #'fossil-ui-discard) + (define-key map (kbd "r") #'fossil-ui-diff-refresh) + (define-key map (kbd "D") #'fossil-ui-diff-toggle) map)) (defconst fossil-ui--diff-evil-bindings - '(("]c" . diff-hunk-next) + '(("D" . fossil-ui-diff-toggle) + ("r" . fossil-ui-diff-refresh) + ("x" . fossil-ui-discard) + ("u" . fossil-ui-unstage) + ("s" . fossil-ui-stage) + ("]c" . diff-hunk-next) ("[c" . diff-hunk-prev) ("TAB" . outline-toggle-children) - ("q" . quit-window)) + ("q" . fossil-ui-quit)) "Bindings which a Fossil diff buffer owns in modal states.") (define-derived-mode fossil-ui-diff-mode diff-mode "Fossil-Diff" @@ -807,11 +1148,18 @@ MINIMUM and GROW are parent-facing Flex sizing hints." (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--own-diff-bindings () + "Keep the generic Diff minor-mode bindings from shadowing Fossil commands." + (when (fboundp 'evil-collection-diff-mode) + (evil-collection-diff-mode -1)) + (when (fboundp 'evil-normalize-keymaps) + (evil-normalize-keymaps))) + +(add-hook 'fossil-ui-diff-mode-hook #'fossil-ui--own-diff-bindings t) + (defun fossil-ui--delta-render (diff) "Render unified DIFF through Delta and return propertized Emacs text. Return nil when Delta exits unsuccessfully." @@ -857,26 +1205,6 @@ Return nil when Delta exits unsuccessfully." (_ (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) @@ -906,6 +1234,57 @@ Return nil when Delta exits unsuccessfully." (fossil-ui-refresh) (message "Stopped tracking %s" path)))) +(defun fossil-ui-delete () + "Delete selected tracked files and stage their removal after confirmation." + (interactive) + (let* ((root (fossil-ui--root)) + (paths (fossil-ui--selected-file-paths)) + (index (fossil-ui--index root)) + (changes (fossil-ui--changes root))) + (fossil-ui--validate-index root index) + (dolist (path paths) + (when (cl-find path + (plist-get index :entries) + :key + (lambda (e) + (plist-get e :path)) + :test #'equal) + (user-error "Unstage %s with u before deleting it" path)) + (when (equal + (plist-get + (cl-find path changes + :key + (lambda (c) + (plist-get c :path)) + :test + #'equal) + :status) + "EXTRA") + (user-error "Use x to delete untracked file %s" path)) + (when (file-directory-p (expand-file-name path root)) + (user-error "Select files, not directories")) + (fossil-ui--clean-buffer (expand-file-name path root))) + (when (yes-or-no-p + (format "Delete from disk and stage removal: %s? " + (string-join paths ", "))) + (unwind-protect + (dolist (path paths) + (fossil-ui--require-success root "rm" "--hard" "--" path) + (when (cl-find-if + (lambda (c) + (and (equal (plist-get c :path) path) + (equal (plist-get c :status) "DELETED"))) + (fossil-ui--changes root)) + (fossil-ui--put-entry root index + (list :path path :base "" :staged "" + :deleted t)) + (setq index (fossil-ui--index root)))) + (when (and (boundp 'evil-state) + (eq evil-state 'visual)) + (evil-exit-visual-state)) + (deactivate-mark) + (fossil-ui-refresh))))) + (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)) @@ -913,16 +1292,49 @@ Return nil when Delta exits unsuccessfully." (user-error "No files selected"))) (defun fossil-ui-revert () - "Revert selected files, or the file at point." + "Revert tracked paths and delete untracked files after confirmation." (interactive) - (let ((paths (fossil-ui--selected-or-current))) + (let* ((paths (fossil-ui--selected-or-current)) + (root (plist-get textui-state :root)) + (changes (fossil-ui--changes root)) + (extras + (seq-filter + (lambda (path) + (equal + (plist-get + (cl-find path changes + :key + (lambda (change) + (plist-get change :path)) + :test + #'equal) + :status) + "EXTRA")) + paths)) + (tracked (seq-difference paths extras #'equal))) + (dolist (path paths) + (fossil-ui--clean-buffer (expand-file-name path root))) (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))))) + (if extras + (format "Delete untracked %s%s? " + (string-join extras ", ") + (if tracked + (format " and revert %d tracked file(s)" + (length tracked)) + "")) + (format "Revert %d file(s)? Fossil undo can restore this once. " + (length tracked)))) + (unwind-protect + (progn + (when tracked + (apply #'fossil-ui--require-success root "revert" "--" + tracked)) + (dolist (path extras) + (delete-file (expand-file-name path root) t)) + (message "Reverted %d tracked file(s), deleted %d untracked file(s)" + (length tracked) + (length extras))) + (fossil-ui-refresh))))) (defun fossil-ui-undo () "Preview and run Fossil's one-level undo." @@ -989,7 +1401,7 @@ Return nil when Delta exits unsuccessfully." (format "*fossil error: %s*" label) (concat output "\n"))))))))))))) -(defun fossil-ui--commit-with-message (message paths) +(defun fossil-ui--commit-marked-files (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")) @@ -1000,18 +1412,6 @@ Return nil when Delta exits unsuccessfully." (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) @@ -1025,24 +1425,54 @@ Return nil when Delta exits unsuccessfully." "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))))))) + "Open or resume the commit message for PATHS below the dashboard." + (let* ((owner (current-buffer)) + (name + (format "*fossil commit: %s*" + (file-name-nondirectory + (directory-file-name (plist-get textui-state :root))))) + (existing (get-buffer name)) + (buffer (get-buffer-create name)) + (window + (or (get-buffer-window buffer) + (split-window + (or (get-buffer-window owner) + (selected-window)) nil + 'below)))) (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))) + (unless (derived-mode-p 'fossil-ui-commit-mode) + (fossil-ui-commit-mode)) + (setq-local default-directory + (buffer-local-value 'default-directory owner) + fossil-ui--commit-owner owner fossil-ui--commit-paths paths) + (unless existing + (erase-buffer))) + (set-window-buffer window buffer) + (select-window window) + (when (fboundp 'evil-insert-state) + (evil-insert-state)) + buffer)) + +(defun fossil-ui--close-commit-buffer (buffer owner) + "Close commit BUFFER and its windows, returning to OWNER." + (let ((owner-window (and (buffer-live-p owner) + (get-buffer-window owner)))) + (dolist (window (get-buffer-window-list buffer nil t)) + (if (one-window-p t (window-frame window)) + (when (buffer-live-p owner) + (set-window-buffer window owner)) + (delete-window window))) + (kill-buffer buffer) + (when (window-live-p owner-window) + (select-window owner-window)))) (defun fossil-ui-commit-submit () - "Submit the current multiline Fossil commit message." + "Submit the commit message, retaining the editor if submission fails." (interactive) - (let ((message (string-trim-right (buffer-substring-no-properties - (point-min) (point-max)))) + (fossil-ui--check-message-stage) + (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))) @@ -1050,22 +1480,20 @@ Return nil when Delta exits unsuccessfully." (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)))) + (fossil-ui--commit-with-message message paths)) + (fossil-ui--close-commit-buffer buffer owner))) (defun fossil-ui-commit-cancel () - "Cancel the current multiline Fossil commit." + "Cancel the message and close its split, retaining staged changes." (interactive) - (let ((owner fossil-ui--commit-owner)) - (kill-buffer (current-buffer)) - (when (buffer-live-p owner) (pop-to-buffer owner)) - (message "Commit cancelled"))) + (fossil-ui--close-commit-buffer (current-buffer) fossil-ui--commit-owner) + (message "Commit cancelled; staged changes retained")) (defun fossil-ui-update () "Update the current Fossil branch." (interactive) + (fossil-ui--guard-checkout-change) (fossil-ui--async "update" '("update"))) (defun fossil-ui-sync () @@ -1078,8 +1506,10 @@ Return nil when Delta exits unsuccessfully." (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"))) + (fossil-ui--guard-checkout-change) + (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) @@ -1088,25 +1518,6 @@ Return nil when Delta exits unsuccessfully." (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)) @@ -1140,24 +1551,30 @@ Return nil when Delta exits unsuccessfully." (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 "<return>") #'fossil-ui-diff) + (define-key map (kbd "RET") #'fossil-ui-visit-file) + (define-key map (kbd "<return>") #'fossil-ui-visit-file) + (define-key map (kbd "P") #'fossil-ui-toggle-preview) (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 "r") #'fossil-ui-refresh) (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 "c c") #'fossil-ui-commit) + (define-key map (kbd "u") #'fossil-ui-unstage) + (define-key map (kbd "s") #'fossil-ui-stage) (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) + (define-key map (kbd "q") #'fossil-ui-quit) + (define-key map (kbd "x") #'fossil-ui-discard) + (define-key map (kbd "TAB") #'fossil-ui-diff) + (define-key map (kbd "<tab>") #'fossil-ui-diff) + (define-key map (kbd "S") #'fossil-ui-sync) + (define-key map (kbd "F") #'fossil-ui-update) + (define-key map (kbd "D") #'fossil-ui-staged-diff) map)) (define-derived-mode fossil-ui-mode textui-mode "Fossil" @@ -1169,72 +1586,53 @@ Return nil when Delta exits unsuccessfully." (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) + '(("D" . fossil-ui-staged-diff) + ("F" . fossil-ui-update) + ("S" . fossil-ui-sync) + ("TAB" . fossil-ui-diff) + ("<tab>" . fossil-ui-diff) + ("x" . fossil-ui-discard) + ("SPC" . fossil-ui-toggle-mark) ("A" . fossil-ui-mark-all) ("X" . fossil-ui-unmark-all) - ("RET" . fossil-ui-diff) - ("<return>" . fossil-ui-diff) + ("RET" . fossil-ui-visit-file) + ("<return>" . fossil-ui-visit-file) + ("P" . fossil-ui-toggle-preview) ("o" . fossil-ui-visit-file) ("a" . fossil-ui-add) ("f" . fossil-ui-forget) - ("r" . fossil-ui-revert) + ("r" . fossil-ui-refresh) ("U" . fossil-ui-undo) - ("c" . fossil-ui-commit) - ("u" . fossil-ui-update) - ("s" . fossil-ui-sync) + ("c c" . fossil-ui-commit) + ("u" . fossil-ui-unstage) + ("s" . fossil-ui-stage) ("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)) + ("q" . fossil-ui-quit)) "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." + "Give Fossil maps precedence over global Evil bindings." (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) + (evil-make-overriding-map fossil-ui-mode-map 'all) (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) + (evil-define-key* '(normal motion visual) fossil-ui-mode-map + (kbd (car binding)) + (cdr binding))) + (evil-make-overriding-map fossil-ui-diff-mode-map 'all) (dolist (binding fossil-ui--diff-evil-bindings) - (evil-define-key* '(normal motion) fossil-ui-diff-mode-map - (kbd (car binding)) (cdr binding))) + (evil-define-key* '(normal motion visual) 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) @@ -1243,32 +1641,23 @@ Return nil when Delta exits unsuccessfully." (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) +(defun fossil-ui--open-dashboard (&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)))) + (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)))) + (let ((buffer (or existing + (get-buffer-create name)))) (with-current-buffer buffer (unless (derived-mode-p 'fossil-ui-mode) (fossil-ui-mode)) @@ -1281,6 +1670,942 @@ Return nil when Delta exits unsuccessfully." (fossil-ui-next-file)) buffer))) +(defvar evil-visual-selection) + +(defun fossil-ui--directory (root) + "Return ROOT's private staging directory." + (expand-file-name (secure-hash 'sha256 (file-truename root)) fossil-ui-stage-directory)) + +(defun fossil-ui--save (file data) + "Atomically save DATA to private FILE." + (make-directory (file-name-directory file) t) + (set-file-modes (file-name-directory file) #o700) + (let ((temporary (make-temp-file (concat file ".")))) + (unwind-protect + (progn + (with-temp-file temporary + (let ((print-length nil) + (print-level nil)) + (prin1 data (current-buffer)))) + (set-file-modes temporary #o600) + (rename-file temporary file t)) + (when (file-exists-p temporary) + (delete-file temporary))))) + +(defun fossil-ui--read (file) + "Read saved data from FILE, if it exists." + (when (file-exists-p file) + (with-temp-buffer + (insert-file-contents file) + (read (current-buffer))))) + +(defun fossil-ui--revision (root) + "Return ROOT's exact checkout revision." + (car (split-string (plist-get (fossil-ui--checkout-info root) :checkout)))) + +(defun fossil-ui--index (root) + "Read ROOT's index, refusing an outstanding commit recovery." + (let ((directory (fossil-ui--directory root))) + (when (file-exists-p (expand-file-name "transaction.eld" directory)) + (user-error "Interrupted partial commit: run M-x fossil-ui-recover in this checkout")) + (let ((index (fossil-ui--read (expand-file-name "index.eld" directory)))) + (if (plist-get index :entries) + index + (list :root root :revision (fossil-ui--revision root) :entries nil))))) + +(defun fossil-ui--ensure-idle (root) + "Refuse writes while a dashboard is running a Fossil operation in ROOT." + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (and (derived-mode-p 'fossil-ui-mode) + (equal (plist-get textui-state :root) root) + (or (plist-get textui-state :busy) + (and fossil-ui--process + (process-live-p fossil-ui--process)))) + (user-error "Fossil is busy; wait for the current operation"))))) + +(defun fossil-ui--validate-index (root index) + "Refuse INDEX if ROOT's base revision changed." + (fossil-ui--ensure-idle root) + (unless (equal (plist-get index :revision) (fossil-ui--revision root)) + (user-error "Checkout changed since staging; inspect staged changes, then clear staging with M-x fossil-ui-clear-stage"))) + +(defun fossil-ui--save-index (root index) + "Persist INDEX for ROOT." + (fossil-ui--save (expand-file-name "index.eld" (fossil-ui--directory root)) index)) + +(defun fossil-ui--text-file (file) + "Read regular UTF-8 FILE exactly, preserving its line endings." + (unless (and (file-regular-p file) + (not (file-symlink-p file))) + (user-error "Partial staging requires a regular file: %s" file)) + (when (> (file-attribute-size (file-attributes file)) fossil-ui-max-stage-bytes) + (user-error "File exceeds fossil-ui-max-stage-bytes: %s" file)) + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-file-contents-literally file) + (let* ((bytes (buffer-string)) + (text (decode-coding-string bytes 'utf-8-unix))) + (when (or (string-search (string 0) bytes) + (not (equal bytes (encode-coding-string text 'utf-8-unix)))) + (user-error "Partial staging requires UTF-8 text: %s" file)) + text))) + +(defun fossil-ui--write-text (file text) + "Write TEXT to FILE preserving UTF-8 bytes and line endings." + (let ((coding-system-for-write 'utf-8-unix)) + (write-region text nil file nil 'silent))) + +(defun fossil-ui--clean-buffer (file) + "Protect unsaved edits and synchronize an unchanged visiting buffer for FILE." + (when-let* ((buffer (find-buffer-visiting file))) + (with-current-buffer buffer + (when (buffer-modified-p) + (user-error "Save the modified file buffer first: %s" file)) + (when (and (file-exists-p file) + (not (verify-visited-file-modtime buffer))) + (revert-buffer t t t))))) + +(defun fossil-ui--base (root path) + "Read exact committed text for PATH, or empty text for an added file." + (let* ((change + (cl-find path + (fossil-ui--changes root) + :key (lambda (c) + (plist-get c :path)) + :test #'equal)) + (status (plist-get change :status))) + (if (or (member status '("ADDED" "EXTRA")) + (and (equal status "MISSING") + (string-empty-p + (fossil-ui--require-success root "ls" "-r" "current" "--" + path)))) + "" + (with-temp-buffer + (let ((default-directory root) + (coding-system-for-read 'utf-8-unix)) + (unless (zerop (process-file fossil-ui-program nil t nil "cat" "-r" "current" "--" path)) + (user-error "Cannot read baseline for %s" path))) + (buffer-string))))) + +(defun fossil-ui--entry (root path index) + "Return PATH's saved entry or its baseline in ROOT and INDEX." + (or (cl-find path + (plist-get index :entries) + :key (lambda (e) + (plist-get e :path)) + :test #'equal) + (let ((base (fossil-ui--base root path))) + (list :path path :base base :staged base)))) + +(defun fossil-ui--put-entry (root index entry) + "Save ENTRY in INDEX for ROOT, dropping empty selections." + (let* ((path (plist-get entry :path)) + (others + (cl-remove path + (plist-get index :entries) + :key (lambda (e) + (plist-get e :path)) + :test #'equal))) + (unless (and (not (plist-get entry :deleted)) + (equal (plist-get entry :base) (plist-get entry :staged))) + (fossil-ui--validate-index root index) + (when (cl-find-if + (lambda (change) + (and (equal (plist-get change :path) path) + (equal (plist-get change :status) + "EXTRA"))) + (fossil-ui--changes root)) + (fossil-ui--require-success root "add" "--" path)) + (push entry others)) + (fossil-ui--save-index root (plist-put index :entries others)))) + +(defun fossil-ui--diff (path left right) + "Return a unified diff from LEFT to RIGHT labeled with PATH." + (let ((a (make-temp-file "fossil-left-")) + (b (make-temp-file "fossil-right-"))) + (unwind-protect + (progn + (fossil-ui--write-text a left) + (fossil-ui--write-text b right) + (with-temp-buffer + (let ((coding-system-for-read 'utf-8-unix)) + (unless (memq (process-file "diff" nil t nil "-U3" "--label" path "--label" path a b) '(0 1)) + (error "Cannot compute staging diff"))) + (buffer-string))) + (delete-file a) + (delete-file b)))) + +(defun fossil-ui--hunks (diff) + "Parse DIFF into hunks with source positions and exact line records." + (with-temp-buffer + (insert diff) + (goto-char (point-min)) + (let (hunks) + (while (re-search-forward "^@@ -\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)? +\\+\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)? @@.*$" nil t) + (let ((hunk + (list :begin (line-beginning-position) + :old (string-to-number (match-string 1)) + :old-count (if (match-string 2) + (string-to-number (match-string 2)) + 1) + :new (string-to-number (match-string 3)) + :new-count (if (match-string 4) + (string-to-number (match-string 4)) + 1))) + lines) + (forward-line 1) + (while (and (not (eobp)) + (memq (char-after) '(?\s ?+ ?- ?\\))) + (if (eq (char-after) ?\\) + (when lines + (setf (plist-get (car lines) :text) (string-remove-suffix "\n" (plist-get (car lines) :text)))) + (push + (list :begin (point) + :end (min (point-max) (1+ (line-end-position))) + :kind (char-after) + :text (buffer-substring-no-properties (1+ (point)) (min (point-max) (1+ (line-end-position))))) + lines)) + (forward-line 1)) + (push (append hunk (list :end (point) :lines (nreverse lines))) hunks))) + (nreverse hunks)))) + +(defun fossil-ui--apply-selection (source diff begin end reverse) + "Apply selected changed lines of DIFF to SOURCE; REVERSE discards or unstages. BEGIN and END are positions in the unmodified diff string; nil selects the entire diff." + (let ((hunks (fossil-ui--hunks diff)) + (changed nil)) + (with-temp-buffer + (insert source) + (dolist (hunk (reverse hunks)) + (let (before after selected) + (dolist (line (plist-get hunk :lines)) + (let* ((kind (plist-get line :kind)) + (text (plist-get line :text)) + (choose + (and (memq kind '(?+ ?-)) + (or (not begin) + (and (< (plist-get line :begin) end) + (> (plist-get line :end) begin))))) + (remove (if reverse + ?+ + ?-)) + (add (if reverse + ?- + ?+))) + (when choose + (setq selected t changed t)) + (when (memq kind (list ?\s remove)) + (push text before)) + (when (or (eq kind ?\s) + (and (eq kind remove) + (not choose)) + (and (eq kind add) + choose)) + (push text after)))) + (when selected + (let* ((line + (plist-get hunk + (if reverse + :new + :old))) + (count + (plist-get hunk + (if reverse + :new-count + :old-count))) + (old (apply #'concat (nreverse before))) + (new (apply #'concat (nreverse after)))) + (goto-char (point-min)) + (forward-line + (if (zerop count) + line + (max 0 (1- line)))) + (unless (and (<= (+ (point) (length old)) (point-max)) + (equal old (buffer-substring-no-properties (point) (+ (point) (length old))))) + (user-error "Diff no longer matches; refresh before changing it")) + (delete-region (point) (+ (point) (length old))) + (insert new))))) + (unless changed + (user-error "Select added or removed lines, or place point inside a hunk")) + (buffer-string)))) + +(defun fossil-ui--root () + "Return the current dashboard or diff root." + (or (plist-get fossil-ui-diff-context :root) + (plist-get textui-state :root) + (user-error "Not a Fossil working buffer"))) + +(defun fossil-ui--bounds () + "Return the visual/active line selection or the hunk at point." + (when (and (boundp 'evil-state) + (eq evil-state 'visual) + (eq evil-visual-selection 'block)) + (user-error "Use v or V for staging lines; rectangular selections are not supported")) + (cond + ((and (boundp 'evil-state) + (eq evil-state 'visual) + (fboundp 'evil-visual-range)) + (let ((range (evil-visual-range))) + (cons (nth 0 range) (nth 1 range)))) + ((use-region-p) + (cons (region-beginning) (region-end))) + (t + (let ((hunk + (cl-find-if + (lambda (h) + (and (<= (plist-get h :begin) (point)) + (< (point) (plist-get h :end)))) + (fossil-ui--hunks (plist-get fossil-ui-diff-context :diff))))) + (unless hunk + (user-error "Place point in a hunk")) + (cons (plist-get hunk :begin) (plist-get hunk :end)))))) + +(defun fossil-ui--show-diff (root path &optional staged owner) + "Show PATH in ROOT as an actionable staged or unstaged diff owned by OWNER." + (let* ((previous-line + (when (and fossil-ui-diff-context + (equal path + (plist-get fossil-ui-diff-context + :path))) + (line-number-at-pos))) + (index (fossil-ui--index root)) + (entry (fossil-ui--entry root path index)) + (_ + (when (or (plist-get entry :deleted) + (cl-find-if + (lambda (c) + (and (equal (plist-get c :path) path) + (equal (plist-get c :status) "DELETED"))) + (fossil-ui--changes root))) + (user-error "File removal is a whole-file change; use s/u in the dashboard"))) + (work + (if (file-exists-p (expand-file-name path root)) + (fossil-ui--text-file (expand-file-name path root)) + "")) + (left + (plist-get entry + (if staged + :base + :staged))) + (right (if staged + (plist-get entry :staged) + work)) + (diff (fossil-ui--diff path left right)) + (colored (fossil-ui--render-diff diff)) + (display + (if (equal diff (substring-no-properties colored)) + colored + diff)) + (buffer + (get-buffer-create + (format "*fossil %s: %s/%s*" + (if staged + "staged" + "unstaged") + (file-name-nondirectory (directory-file-name root)) path)))) + (with-current-buffer buffer + (fossil-ui-diff-mode) + (when (text-property-not-all 0 (length display) 'face nil display) + (font-lock-mode -1)) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert display)) + (setq-local default-directory root + fossil-ui-diff-context + (list :root root + :path path + :staged staged + :work work + :left left + :right right + :diff diff + :owner owner) + header-line-format + (format "%s · %s · s stage · u unstage · x discard · v/V select lines · D switch staged/unstaged · r refresh" + (if staged + "Staged" + "Unstaged") + path)) + (goto-char (point-min)) + (when previous-line + (forward-line (1- previous-line))) + (unless (cl-some + (lambda (hunk) + (and (<= (plist-get hunk :begin) (point)) + (< (point) (plist-get hunk :end)))) + (fossil-ui--hunks diff)) + (goto-char (point-min)) + (re-search-forward "^@@" nil t) + (beginning-of-line))) + (let* ((owner-window (and (buffer-live-p owner) + (get-buffer-window owner))) + (existing + (cl-find-if + (lambda (window) + (and owner + (eq (window-parameter window 'fossil-ui-diff-owner) + owner) + (with-current-buffer + (window-buffer window) + (derived-mode-p + 'fossil-ui-diff-mode)))) + (window-list))) + (window + (or existing + (and owner-window + (split-window owner-window nil 'right)) + (selected-window)))) + (set-window-buffer window buffer) + (when owner-window + (set-window-parameter window 'fossil-ui-diff-owner + owner)) + (select-window window)) + buffer)) + +(defun fossil-ui-diff (&optional staged) + "Open the file at point; prefix STAGED shows the selection to commit." + (interactive "P") + (let ((path + (or (fossil-ui--path-at-point) + (plist-get textui-state :preview-path) + (user-error "No file at point")))) + (fossil-ui--show-diff + (fossil-ui--root) path + (or staged + (equal (fossil-ui--status-at-point) "STAGED")) + (current-buffer)))) + +(defun fossil-ui-diff-refresh (&optional toggle) + "Refresh this diff; TOGGLE switches between staged and unstaged." + (interactive) + (let ((context fossil-ui-diff-context)) + (fossil-ui--show-diff + (plist-get context :root) + (plist-get context :path) + (if toggle + (not (plist-get context :staged)) + (plist-get context :staged)) + (plist-get context :owner)))) + +(defun fossil-ui-diff-toggle () + "Switch between staged and unstaged changes." + (interactive) + (fossil-ui-diff-refresh t)) + +(defun fossil-ui--refresh-owner (owner) + "Refresh dashboard OWNER if it still exists." + (when (buffer-live-p owner) + (with-current-buffer owner + (fossil-ui-refresh)))) + +(defun fossil-ui--change-selection (action) + "Perform stage, unstage or discard ACTION in an actionable diff." + (unless fossil-ui-diff-context + (user-error "Open an actionable file diff with TAB first")) + (let* ((context fossil-ui-diff-context) + (root (plist-get context :root)) + (path (plist-get context :path)) + (file (expand-file-name path root)) + (index (fossil-ui--index root)) + (entry (copy-sequence (fossil-ui--entry root path index))) + (staged (plist-get context :staged)) + (bounds (fossil-ui--bounds)) + (diff (plist-get context :diff))) + (fossil-ui--validate-index root index) + (fossil-ui--clean-buffer file) + (unless (and (equal (plist-get context :work) (fossil-ui--text-file file)) + (equal + (plist-get entry + (if staged + :base + :staged)) + (plist-get context :left)) + (or (not staged) + (equal (plist-get entry :staged) (plist-get context :right)))) + (user-error "File or staging changed; press r to refresh")) + (when (or (and (eq action 'stage) + staged) + (and (eq action 'unstage) + (not staged))) + (user-error "Press D to switch to %s changes first" + (if staged + "unstaged" + "staged"))) + (when (and staged + (eq action 'discard)) + (user-error "Unstage with u first, then discard in the unstaged diff")) + (let ((result + (fossil-ui--apply-selection + (plist-get context + (if (eq action 'stage) + :left + :right)) + diff + (car bounds) + (cdr bounds) + (not (eq action 'stage))))) + (if (eq action 'discard) + (when (or (not fossil-ui-confirm-revert) + (yes-or-no-p (format "Discard selected working changes in %s? " path))) + (let ((buffer (find-file-noselect file))) + (with-current-buffer buffer + (undo-boundary) + (atomic-change-group + (erase-buffer) + (insert (decode-coding-string (encode-coding-string result 'utf-8-unix) buffer-file-coding-system))) + (fossil-ui--write-text file result) + (set-visited-file-modtime) + (set-buffer-modified-p nil) + (undo-boundary)))) + (fossil-ui--put-entry root index (plist-put entry :staged result)))) + (when (and (fboundp 'evil-exit-visual-state) + (boundp 'evil-state) + (eq evil-state 'visual)) + (evil-exit-visual-state)) + (deactivate-mark) + (fossil-ui--refresh-owner (plist-get context :owner)) + (fossil-ui-diff-refresh) + (when (and (eq action 'stage) + (string-empty-p (plist-get fossil-ui-diff-context :diff))) + (fossil-ui-quit)))) + +(defun fossil-ui--selected-file-paths () + "Return unique file paths in the visual region or at point." + (let ((range + (cond + ((and (boundp 'evil-state) + (eq evil-state 'visual)) + (when (eq evil-visual-selection 'block) + (user-error "Use V to select file rows")) + (evil-visual-range)) + ((use-region-p) + (list (region-beginning) (region-end)))))) + (if (not range) + (list (or (fossil-ui--path-at-point) + (user-error "No file at point"))) + (let ((pos (car range)) + (end (cadr range)) + paths) + (while (< pos end) + (when-let* ((path (get-text-property pos 'fossil-ui-path))) + (unless (member path paths) + (push path paths))) + (setq pos (next-single-property-change pos 'fossil-ui-path nil end))) + (or (nreverse paths) + (user-error "No files in selection")))))) + +(defun fossil-ui--change-files (stage) + "Stage selected files when STAGE is non-nil; otherwise unstage them." + (let* ((root (fossil-ui--root)) + (paths (fossil-ui--selected-file-paths)) + (index (fossil-ui--index root)) + (changes (fossil-ui--changes root)) + (entries + (mapcar + (lambda (path) + (let* ((file (expand-file-name path root)) + (deleted + (equal + (plist-get + (cl-find path changes + :key + (lambda (c) + (plist-get c :path)) + :test #'equal) + :status) + "DELETED")) + (entry + (if deleted + (list :path path :base "" :staged "") + (copy-sequence + (fossil-ui--entry root path + index))))) + (when stage + (fossil-ui--clean-buffer file)) + (if deleted + (plist-put entry :deleted stage) + (plist-put entry + :staged + (if stage + (fossil-ui--text-file file) + (plist-get entry :base)))))) + paths))) + (fossil-ui--validate-index root index) + (dolist (entry entries) + (fossil-ui--put-entry root index entry) + (setq index (fossil-ui--index root))) + (when (and (boundp 'evil-state) + (eq evil-state 'visual)) + (evil-exit-visual-state)) + (deactivate-mark) + (fossil-ui-refresh))) + +(defun fossil-ui-stage () + "Stage selected file rows, or selected hunks and lines in a diff." + (interactive) + (if fossil-ui-diff-context + (fossil-ui--change-selection 'stage) + (fossil-ui--change-files t))) + +(defun fossil-ui-unstage () + "Unstage selected file rows, or selected hunks and lines in a diff." + (interactive) + (if fossil-ui-diff-context + (fossil-ui--change-selection 'unstage) + (fossil-ui--change-files nil))) + +(defun fossil-ui-discard () + "Discard the hunk/visual lines, or unstaged dashboard files after confirmation." + (interactive) + (fossil-ui--ensure-idle (fossil-ui--root)) + (cond + (fossil-ui-diff-context (fossil-ui--change-selection 'discard)) + ((equal (fossil-ui--status-at-point) "STAGED") + (user-error "Unstage with u before discarding")) + (t (fossil-ui-revert)))) + +(defun fossil-ui-clear-stage () + "Clear this checkout's staging snapshots after confirmation." + (interactive) + (let ((root (fossil-ui--root))) + (when (yes-or-no-p "Clear all staged selections? Working files stay unchanged. ") + (let ((index (fossil-ui--index root))) + (fossil-ui--save-index root + (plist-put (plist-put index :revision (fossil-ui--revision root)) :entries nil))) + (when (derived-mode-p 'fossil-ui-mode) + (fossil-ui-refresh))))) + +(defun fossil-ui--restore-transaction (root transaction) + "Restore working files from TRANSACTION in ROOT without overwriting intervening edits." + (dolist (item (plist-get transaction :files)) + (let* ((file (expand-file-name (plist-get item :path) root)) + (original (fossil-ui--text-file (plist-get item :backup))) + (current (fossil-ui--text-file file))) + (unless (or (equal current original) + (equal current (plist-get item :staged))) + (user-error "File changed during commit: %s; recovery copies retained in %s" file + (fossil-ui--directory root))) + (unless (equal current original) + (copy-file (plist-get item :backup) file t t t) + (set-file-modes file (plist-get item :mode))) + (when-let* ((buffer (find-buffer-visiting file))) + (with-current-buffer buffer + (set-visited-file-modtime))))) + (let ((revision (fossil-ui--revision root))) + (unless (equal revision (plist-get transaction :revision)) + (fossil-ui--save-index root (list :root root :revision revision :entries nil)))) + (delete-file (expand-file-name "transaction.eld" (fossil-ui--directory root))) + (dolist (item (plist-get transaction :files)) + (delete-file (plist-get item :backup)))) + +(defun fossil-ui-recover () + "Restore working files after an interrupted partial commit, retaining ambiguous edits." + (interactive) + (let* ((root + (or (ignore-errors (fossil-ui--root)) + (plist-get (fossil-ui--checkout-info default-directory) :root))) + (transaction (fossil-ui--read (expand-file-name "transaction.eld" (fossil-ui--directory root))))) + (unless transaction + (user-error "No interrupted partial commit for this checkout")) + (fossil-ui--restore-transaction root transaction) + (message "Working files restored; inspect Fossil status before committing again"))) + +(defun fossil-ui--commit-staged (root message) + "Commit ROOT's staged snapshots with MESSAGE and restore all remaining edits." + (let* ((index (fossil-ui--index root)) + (entries (plist-get index :entries)) + (directory (fossil-ui--directory root)) + (transaction-file (expand-file-name "transaction.eld" directory)) + (transaction (list :revision (fossil-ui--revision root) :files nil)) + (inhibit-quit t)) + (fossil-ui--validate-index root index) + (unless entries + (user-error "Nothing staged; use s first")) + (when (string-empty-p (string-trim message)) + (user-error "Commit message cannot be empty")) + (when (string-match-p "^\\(?:MERGED\\|CONFLICT\\)" + (fossil-ui--require-success root "changes" "--classify")) + (user-error "Resolve/commit the pending merge before partial commits")) + (make-directory directory t) + ;; Prepare every durable backup before touching any working file. + (dolist (entry entries) + (when (plist-get entry :deleted) + (fossil-ui--clean-buffer + (expand-file-name (plist-get entry :path) root)) + (when (or (file-exists-p + (expand-file-name (plist-get entry :path) root)) + (not + (cl-find-if + (lambda (c) + (and (equal (plist-get c :path) + (plist-get entry :path)) + (equal (plist-get c :status) "DELETED"))) + (fossil-ui--changes root)))) + (user-error "Deletion changed; unstage and review %s" + (plist-get entry :path))))) + (dolist (entry (seq-remove (lambda (e) + (plist-get e :deleted)) entries)) + (let* ((path (plist-get entry :path)) + (file (expand-file-name path root)) + (backup (make-temp-file (expand-file-name "working-" directory)))) + (fossil-ui--clean-buffer file) + (fossil-ui--text-file file) + (copy-file file backup t t t) + (set-file-modes backup #o600) + (push + (list :path path :backup backup :mode (file-modes file) :staged (plist-get entry :staged)) + (plist-get transaction :files)))) + (fossil-ui--save transaction-file transaction) + (unwind-protect + (progn + (dolist (entry + (seq-remove + (lambda (e) + (plist-get e :deleted)) + entries)) + (fossil-ui--write-text (expand-file-name (plist-get entry :path) root) (plist-get entry :staged))) + (apply #'fossil-ui--require-success root "commit" "--hash" "--nosync" "--no-prompt" "--comment" message "--" + (mapcar (lambda (e) + (plist-get e :path)) entries))) + (fossil-ui--restore-transaction root transaction)))) + +(defun fossil-ui--commit-with-message (message paths) + "Commit staged snapshots or marked PATHS with MESSAGE." + (let* ((root (fossil-ui--root)) + (index (fossil-ui--index root))) + (if (not (plist-get index :entries)) + (fossil-ui--commit-marked-files message paths) + (when (plist-get textui-state :busy) + (user-error "Fossil is busy")) + (fossil-ui--commit-staged root message) + (textui-set-state (current-buffer) :selected nil) + (fossil-ui-refresh) + (message "Staged changes committed locally; remaining edits restored. S synchronizes.")))) + +(defun fossil-ui-commit (&optional _edit) + "Open the commit-message split for staged snapshots or marked files." + (interactive "P") + (let* ((index (fossil-ui--index (fossil-ui--root))) + (entries (plist-get index :entries)) + (paths + (if entries + (mapcar + (lambda (entry) + (plist-get entry :path)) + entries) + (plist-get textui-state :selected)))) + (unless paths + (user-error "Stage changes with s first")) + (when (and entries + (plist-get textui-state :selected)) + (user-error "Clear old file marks with X before committing staged changes")) + (fossil-ui--open-commit-buffer paths) + (setq-local fossil-ui-commit-index (and entries + index)))) + +(defun fossil-ui--check-message-stage (&rest _) + "Keep an open staged-commit message from committing a changed selection." + (when fossil-ui-commit-index + (unless (and (buffer-live-p fossil-ui--commit-owner) + (equal fossil-ui-commit-index + (fossil-ui--index (buffer-local-value 'default-directory fossil-ui--commit-owner)))) + (user-error "Staging changed while writing the message; cancel and review the selection before committing")))) + +(defun fossil-ui--guard-checkout-change (&rest _) + "Require staged selections to be committed or cleared before changing the checkout." + (when (plist-get (fossil-ui--index (fossil-ui--root)) :entries) + (user-error "Commit or clear staged selections before updating or switching branches"))) + +(defun fossil-ui--snapshot (directory &optional selected) + "Collect checkout and staging state for DIRECTORY and SELECTED." + (let* ((state (fossil-ui--checkout-snapshot directory selected)) + (root (plist-get state :root)) + (index (condition-case err (fossil-ui--index root) (error (list :error (error-message-string err))))) + (entries (plist-get index :entries))) + (when-let* ((error-text (plist-get index :error))) + (setq state (plist-put state :error error-text))) + (when (and entries + (not (equal (plist-get index :revision) (car (split-string (plist-get state :checkout)))))) + (setq state + (plist-put state + :error "Staging belongs to an older checkout; inspect and clear it before continuing."))) + (setq state (plist-put state :stage-entries entries)) + (let ((changes (copy-tree (plist-get state :changes)))) + (dolist (entry entries) + (let* ((path (plist-get entry :path)) + (file (expand-file-name path root)) + (change + (cl-find path changes + :key (lambda (c) + (plist-get c :path)) + :test #'equal))) + (when (plist-get entry :deleted) + (setq changes + (cl-remove path changes + :key + (lambda (c) + (plist-get c :path)) + :test + #'equal))) + (when (and (file-regular-p file) + (not (file-symlink-p file))) + (let ((work (condition-case nil (fossil-ui--text-file file) (error nil)))) + (if (equal work (plist-get entry :staged)) + (setq changes + (cl-remove path changes + :key (lambda (c) + (plist-get c :path)) + :test #'equal)) + (unless change + (push (list :path path :status "EDITED") changes))))))) + (plist-put state :unstaged changes)))) + +(defun fossil-ui--stage-panel (width) + "Render the persistent staging selection and remaining changes at WIDTH." + (let ((entries (plist-get textui-state :stage-entries))) + (fossil-ui--card + (format "Staged changes · %d files" (length entries)) + (if entries + (mapcar + (lambda (entry) + (fossil-ui--change-row + (list :path (plist-get entry :path) :status "STAGED") + (max 8 (- width 4)) + (list (plist-get entry :path)))) + entries) + (list + (fossil-ui--text "Nothing staged. s selects a file; TAB opens hunks, v/V selects changed lines, and s stages that selection." 'fossil-ui-faded))) + width))) + +(defun fossil-ui--unstaged-panel (width state) + "Show remaining working changes at WIDTH from STATE." + (let* ((changes + (if (plist-member state :unstaged) + (plist-get state :unstaged) + (plist-get state :changes))) + (card (fossil-ui--changes-panel width changes (plist-get state :selected)))) + (setf + (car (plist-get card :children)) + (fossil-ui--text (format "Unstaged changes · %d files" (length changes)) 'fossil-ui-strong)) + (unless changes + (setf + (cadr (plist-get card :children)) + (fossil-ui--column (list (fossil-ui--text "No unstaged changes." 'success))))) + card)) + +(defun fossil-ui-refresh-timeline () + "Refresh only recent commits while preserving unchanged timeline entries." + (interactive) + (setq textui-state (plist-put textui-state :timeline (fossil-ui--timeline (fossil-ui--root)))) + (if fossil-ui-keyed-timeline + (textui-reconcile-keyed-region (current-buffer) 'fossil-timeline #'fossil-ui--timeline-entries) + (textui-refresh (current-buffer)))) + +(defun fossil-ui--timeline-entries (width) + "Return stable keyed timeline entries at WIDTH." + (mapcar + (lambda (entry) + (list + (or (alist-get 'uuid entry) + (format "%S" entry)) + (fossil-ui--column (fossil-ui--timeline-elements entry width)))) + (seq-take (plist-get textui-state :timeline) (fossil-ui--timeline-count)))) + +(defun fossil-ui--frame (width) + "Render the working dashboard with full-width stable timeline and staging sections." + (let* ((width + (max 1 + (if fossil-ui-content-width + (min width fossil-ui-content-width) + width))) + (state textui-state) + (elements (fossil-ui--screen-elements width)) + (prefix (butlast elements 2)) + (entries (fossil-ui--timeline-entries width))) + (let ((parts + (append + (list + (fossil-ui--column prefix) + (fossil-ui--stage-panel width) + (fossil-ui--unstaged-panel width state)) + (when (plist-get state :preview-path) + (list `(:type fossil-ui-preview + :path ,(plist-get state :preview-path) + :value ,(plist-get state :preview)))) + (list + (fossil-ui--text "Recent commits" 'fossil-ui-strong) + `(:type :flex + :direction :column + :gap 1 + :layout (:refresh-id fossil-timeline) + :children ,(or (mapcar #'cadr entries) + (list (fossil-ui--item "No commits available")))) + (fossil-ui--text "s Stage · u Unstage · x Discard · d Delete · c c Commit · S Sync · F Update · RET File · TAB Diff · D Staged diff · P Preview · q Back" 'fossil-ui-faded))))) + (cl-loop for part in parts for first = t then nil + unless first collect '(:type :text :value "\n\n" :align left :wrap greedy) + collect part)))) + +(defun fossil-ui--after-refresh (&optional buffer &rest _) + "Install or reconcile the full-width timeline after BUFFER's dashboard refresh." + (with-current-buffer (or buffer + (current-buffer)) + (when (and fossil-ui-keyed-timeline + (derived-mode-p 'fossil-ui-mode) + (assq 'fossil-timeline textui--refresh-regions)) + (textui-reconcile-keyed-region (current-buffer) 'fossil-timeline #'fossil-ui--timeline-entries)))) + +(defun fossil-ui-status (&optional directory) + "Open DIRECTORY's Fossil dashboard full-frame, remembering the previous windows." + (interactive) + (let* ((configuration (current-window-configuration)) + (buffer (fossil-ui--open-dashboard directory))) + (when fossil-ui-full-frame + (switch-to-buffer buffer) + (delete-other-windows) + (with-current-buffer buffer + (unless fossil-ui-window-configuration + (setq fossil-ui-window-configuration configuration)) + (textui-refresh buffer))) + buffer)) + +(defun fossil-ui-quit () + "Close this Fossil buffer and its diff window, or restore the previous layout." + (interactive) + (let ((buffer (current-buffer)) + (owner (plist-get fossil-ui-diff-context :owner)) + (configuration fossil-ui-window-configuration)) + (cond + (fossil-ui-diff-context + (let ((owner-window (and (buffer-live-p owner) + (get-buffer-window owner)))) + (dolist (window (get-buffer-window-list buffer nil t)) + (if (one-window-p t (window-frame window)) + (when (buffer-live-p owner) + (set-window-buffer window owner)) + (delete-window window))) + (kill-buffer buffer) + (when (window-live-p owner-window) + (select-window owner-window)))) + (configuration + (setq fossil-ui-window-configuration nil) + (set-window-configuration configuration) + (kill-buffer buffer)) + (t (quit-window t))))) + +(defun fossil-ui-help () + "Show the workflow's actual keybindings and selection semantics." + (interactive) + (fossil-ui--show-output "*fossil-ui help*" + "Fossil workflow\n\ns / u Stage / unstage file, hunk, or selected changed lines\nx Discard working file or selected unstaged diff lines (asks first)\nv / V Select changed lines in a diff; partial characters select their whole lines\nRET Open file\nTAB Open actionable diff in a split\nD Open staged diff / switch staged and unstaged views\n[c ]c Previous / next hunk; TAB folds a hunk\nr Refresh; stale diffs refuse writes\nc c Open commit editor; C-c C-c submits, C-c C-k cancels\nS Synchronize; F updates the checkout; b switches branch\nP Toggle read-only dashboard preview; use TAB for hunk actions\nq Return to dashboard / restore previous window layout\n\nStaging persists locally across Emacs restarts. Partial staging supports regular UTF-8 text files, including added files, with original line endings preserved. Binary files, symlinks, renames/deletions, and pending merges require whole-file handling. Legacy SPC/A/X file marks remain available for that purpose; do not mix marks with staging.\n\nPartial commits run locally without autosync, restore remaining edits, and retain recovery data on interruption. Use S to synchronize. M-x fossil-ui-recover restores interrupted commits; M-x fossil-ui-clear-stage clears an outdated selection. Hunk discard uses the visiting file buffer, so Emacs undo can restore it.\n")) + +(defun fossil-ui-staged-diff () + "Open staged changes of the dashboard file." + (interactive) + (fossil-ui-diff t)) + +(advice-add 'textui-refresh :after #'fossil-ui--after-refresh) +(advice-add 'textui-refresh :around #'fossil-ui--preserve-dashboard-position) + ;;;###autoload (defalias 'fossil-ui #'fossil-ui-status) diff --git a/test/fossil-ui-test.el b/test/fossil-ui-test.el index bc1e8ce..6b61bd9 100644 --- a/test/fossil-ui-test.el +++ b/test/fossil-ui-test.el @@ -108,9 +108,10 @@ (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)))) + (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 @@ -118,16 +119,21 @@ (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))) + (should (string-match-p "Staged changes" rendered)) + (should (string-match-p "Unstaged changes" 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)))) + (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")))))))))) + (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)) @@ -160,7 +166,7 @@ (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 "No unstaged changes" rendered)) (should (string-match-p "Running" rendered)) (should (string-match-p "sync is running" rendered)) (should (string-match-p "Error" rendered)) @@ -244,5 +250,48 @@ (should-error (fossil-ui--checkout-info directory) :type 'user-error) (delete-directory directory t)))) +(ert-deftest fossil-ui-preview-block-resizes-and-retains-diff-faces () + (let* ((fossil-ui-preview-lines 3) + (widget + (widget-convert 'fossil-ui-preview + :path "tracked.txt" + :value "@@ -1 +1 @@\n-old\n+new\n context"))) + (dolist (width '(20 80 120)) + (let ((rendered (textui-layout-widget widget width))) + (should (text-property-not-all 0 (length rendered) 'face nil rendered)) + (dolist (line (split-string rendered "\n")) + (should (<= (string-width line) width))) + (with-temp-buffer + (insert rendered) + (textui-attach-widget widget (point-min) (point-max)) + (should (equal (buffer-string) rendered)) + (widget-delete widget)))))) + +(ert-deftest fossil-ui-preview-toggle-refresh-and-clean-checkout () + (fossil-ui-test--with-checkout + (fossil-ui-test--write (expand-file-name "tracked.txt" root) "preview change\n") + (let ((buffer (save-window-excursion (fossil-ui-status root)))) + (unwind-protect + (with-current-buffer buffer + (fossil-ui--goto-path "tracked.txt") + (should (eq (key-binding (kbd "P")) #'fossil-ui-toggle-preview)) + (fossil-ui-toggle-preview) + (should (equal (plist-get textui-state :preview-path) "tracked.txt")) + (textui-refresh buffer) + (should (string-search "+preview change" (buffer-substring-no-properties (point-min) (point-max)))) + (fossil-ui-test--write (expand-file-name "tracked.txt" root) "new preview\n") + (fossil-ui-refresh) + (textui-refresh buffer) + (should (string-search "+new preview" (buffer-substring-no-properties (point-min) (point-max)))) + (fossil-ui--goto-path "tracked.txt") + (fossil-ui-toggle-preview) + (should-not (plist-get textui-state :preview-path)) + (fossil-ui-toggle-preview) + (fossil-ui-test--write (expand-file-name "tracked.txt" root) "initial\n") + (fossil-ui-refresh) + (should-not (plist-get textui-state :preview-path))) + (when (buffer-live-p buffer) + (kill-buffer buffer)))))) + (provide 'fossil-ui-test) ;;; fossil-ui-test.el ends here diff --git a/themes/tinty-theme.el b/themes/tinty-theme.el index 2942c9e..0e32aac 100644 --- a/themes/tinty-theme.el +++ b/themes/tinty-theme.el @@ -65,67 +65,67 @@ (deftheme tinty "Noctalia theme with proper color contrast.") (let* (;; Tinted8 UI surface colors - (ui-bg "#f5f5f5") - (ui-fg "#1f1f1f") - (ui-fg-dim "#4f4f4f") + (ui-bg "#22212c") + (ui-fg "#f8f8f2") + (ui-fg-dim "#babaab") ;; Use dim foreground for borders/muted chrome so they stay visible in ;; light variants (the raw border color is nearly white on latte). - (ui-border "#4f4f4f") - (ui-line-highlight "#cfcfde") - (ui-bg-dark "#e5e5e5") - (ui-bg-light "#c5c5c5") + (ui-border "#babaab") + (ui-line-highlight "#454158") + (ui-bg-dark "#201f2e") + (ui-bg-light "#36334c") ;; Tinted8 UI accent/status colors - (ui-accent "#686e93") - (ui-link "#036a96") - (ui-info "#336699") - (ui-error "#cb3a2a") - (ui-success "#14710a") - (ui-warning "#a34d14") + (ui-accent "#b4befe") + (ui-link "#80ffea") + (ui-info "#8c78f0") + (ui-error "#ff9580") + (ui-success "#8aff80") + (ui-warning "#ffca80") ;; Tinted8 UI container colors (for BACKGROUNDS only) - (ui-selection-bg "#cfcfde") - (ui-selection-fg "#1f1f1f") - (ui-button-bg "#d5d5d5") - (ui-button-fg "#1f1f1f") - (ui-tooltip-bg "#e5e5e5") - (ui-tooltip-fg "#1f1f1f") - (ui-active-text-bg "#cfcfde") - (ui-active-text-fg "#2f2f2f") - (ui-search-bg "#e5e5e5") - (ui-search-fg "#2f2f2f") + (ui-selection-bg "#454158") + (ui-selection-fg "#f8f8f2") + (ui-button-bg "#2b293d") + (ui-button-fg "#f8f8f2") + (ui-tooltip-bg "#201f2e") + (ui-tooltip-fg "#f8f8f2") + (ui-active-text-bg "#454158") + (ui-active-text-fg "#ededde") + (ui-search-bg "#201f2e") + (ui-search-fg "#ededde") ;; Tinted8 syntax colors ;; Comments use dim foreground instead of the raw syntax-comment gray, ;; which becomes almost invisible in light variants. - (syntax-comment "#4f4f4f") - (syntax-constant "#a34d14") - (syntax-function "#14710a") - (syntax-keyword "#a3144d") - (syntax-string "#846e15") - (syntax-type "#036a96") + (syntax-comment "#babaab") + (syntax-constant "#ffca80") + (syntax-function "#8aff80") + (syntax-keyword "#ff80bf") + (syntax-string "#ffff80") + (syntax-type "#80ffea") ;; Give variables/imported names a distinct hue instead of blending into ;; the default foreground. - (syntax-variable "#1f1f1f") - (syntax-warning "#cb3a2a") - (syntax-preprocessor "#336699") - (syntax-annotation "#846e15") - (syntax-attribute "#036a96") - (syntax-number "#a34d14") - (syntax-operator "#036a96") + (syntax-variable "#f8f8f2") + (syntax-warning "#ff9580") + (syntax-preprocessor "#8c78f0") + (syntax-annotation "#ffff80") + (syntax-attribute "#80ffea") + (syntax-number "#ffca80") + (syntax-operator "#80ffea") ;; Raw palette colors for rainbow headings, delimiters, terminal faces, ;; and anywhere else we need a predictable hue cycle. - (pal-red "#cb3a2a") - (pal-orange "#a34d14") - (pal-yellow "#846e15") - (pal-green "#14710a") - (pal-cyan "#036a96") - (pal-blue "#644ac9") - (pal-magenta "#a3144d") - (pal-gray "#635d97") - (pal-white "#6e6e6e") - (pal-black "#1f1f1f") + (pal-red "#ff9580") + (pal-orange "#ffca80") + (pal-yellow "#ffff80") + (pal-green "#8aff80") + (pal-cyan "#80ffea") + (pal-blue "#9580ff") + (pal-magenta "#ff80bf") + (pal-gray "#8a83b4") + (pal-white "#f8f8f2") + (pal-black "#8a898f") (h1 (if tinty-scale-headings tinty-height-1 1.0)) (h2 (if tinty-scale-headings tinty-height-2 1.0)) (h3 (if tinty-scale-headings tinty-height-3 1.0)) @@ -344,13 +344,13 @@ ;; === Terminal colors - mapped to the palette so they stay correct in both variants === `(term-color-black ((t (:foreground ,ui-bg-dark :background ,ui-bg-dark)))) - `(term-color-red ((t (:foreground "#cb3a2a" :background "#cb3a2a")))) - `(term-color-green ((t (:foreground "#14710a" :background "#14710a")))) - `(term-color-yellow ((t (:foreground "#846e15" :background "#846e15")))) - `(term-color-blue ((t (:foreground "#644ac9" :background "#644ac9")))) - `(term-color-magenta ((t (:foreground "#a3144d" :background "#a3144d")))) - `(term-color-cyan ((t (:foreground "#036a96" :background "#036a96")))) - `(term-color-white ((t (:foreground "#6e6e6e" :background "#6e6e6e")))) + `(term-color-red ((t (:foreground "#ff9580" :background "#ff9580")))) + `(term-color-green ((t (:foreground "#8aff80" :background "#8aff80")))) + `(term-color-yellow ((t (:foreground "#ffff80" :background "#ffff80")))) + `(term-color-blue ((t (:foreground "#9580ff" :background "#9580ff")))) + `(term-color-magenta ((t (:foreground "#ff80bf" :background "#ff80bf")))) + `(term-color-cyan ((t (:foreground "#80ffea" :background "#80ffea")))) + `(term-color-white ((t (:foreground "#f8f8f2" :background "#f8f8f2")))) ;; === EShell === `(eshell-prompt ((t (:foreground ,ui-accent :weight bold)))) @@ -556,14 +556,14 @@ `(ansi-color-magenta ((t (:foreground ,pal-magenta :background ,pal-magenta)))) `(ansi-color-cyan ((t (:foreground ,pal-cyan :background ,pal-cyan)))) `(ansi-color-white ((t (:foreground ,pal-white :background ,pal-white)))) - `(ansi-color-bright-black ((t (:foreground "#4f4f4f" :background "#4f4f4f")))) - `(ansi-color-bright-red ((t (:foreground "#cb3a2a" :background "#cb3a2a")))) - `(ansi-color-bright-green ((t (:foreground "#14710a" :background "#14710a")))) - `(ansi-color-bright-yellow ((t (:foreground "#846e15" :background "#846e15")))) - `(ansi-color-bright-blue ((t (:foreground "#644ac9" :background "#644ac9")))) - `(ansi-color-bright-magenta ((t (:foreground "#a3144d" :background "#a3144d")))) - `(ansi-color-bright-cyan ((t (:foreground "#036a96" :background "#036a96")))) - `(ansi-color-bright-white ((t (:foreground "#707070" :background "#707070")))) + `(ansi-color-bright-black ((t (:foreground "#8a8997" :background "#8a8997")))) + `(ansi-color-bright-red ((t (:foreground "#ff9580" :background "#ff9580")))) + `(ansi-color-bright-green ((t (:foreground "#8aff80" :background "#8aff80")))) + `(ansi-color-bright-yellow ((t (:foreground "#ffff80" :background "#ffff80")))) + `(ansi-color-bright-blue ((t (:foreground "#9580ff" :background "#9580ff")))) + `(ansi-color-bright-magenta ((t (:foreground "#ff80bf" :background "#ff80bf")))) + `(ansi-color-bright-cyan ((t (:foreground "#80ffea" :background "#80ffea")))) + `(ansi-color-bright-white ((t (:foreground "#ededde" :background "#ededde")))) ;; === Anzu === `(anzu-replace-highlight ((t (:background ,ui-line-highlight :foreground ,ui-error :weight bold :strike-through t)))) @@ -1365,14 +1365,14 @@ ;; === Term (extended) === `(term ((t (:foreground ,ui-fg :background ,ui-bg)))) `(term-bold ((t (:weight bold)))) - `(term-color-bright-black ((t (:foreground "#4f4f4f" :background "#4f4f4f")))) - `(term-color-bright-red ((t (:foreground "#cb3a2a" :background "#cb3a2a")))) - `(term-color-bright-green ((t (:foreground "#14710a" :background "#14710a")))) - `(term-color-bright-yellow ((t (:foreground "#846e15" :background "#846e15")))) - `(term-color-bright-blue ((t (:foreground "#644ac9" :background "#644ac9")))) - `(term-color-bright-magenta ((t (:foreground "#a3144d" :background "#a3144d")))) - `(term-color-bright-cyan ((t (:foreground "#036a96" :background "#036a96")))) - `(term-color-bright-white ((t (:foreground "#707070" :background "#707070")))) + `(term-color-bright-black ((t (:foreground "#8a8997" :background "#8a8997")))) + `(term-color-bright-red ((t (:foreground "#ff9580" :background "#ff9580")))) + `(term-color-bright-green ((t (:foreground "#8aff80" :background "#8aff80")))) + `(term-color-bright-yellow ((t (:foreground "#ffff80" :background "#ffff80")))) + `(term-color-bright-blue ((t (:foreground "#9580ff" :background "#9580ff")))) + `(term-color-bright-magenta ((t (:foreground "#ff80bf" :background "#ff80bf")))) + `(term-color-bright-cyan ((t (:foreground "#80ffea" :background "#80ffea")))) + `(term-color-bright-white ((t (:foreground "#ededde" :background "#ededde")))) ;; === Transient === `(transient-heading ((t (:foreground ,ui-accent :weight bold)))) |