Add 10 new Emacs features: centered-cursor, beacon, dimmer, savehist, so-long, subword, recentf, prettify-symbols, delete-selection, which-function
ober
bb5e7373110772bd13cecdb05b04a01346eba9ac
--- a/src/jerboa-emacs/app.ss +++ b/src/jerboa-emacs/app.ss @@ -27,6 +27,7 @@ :jerboa-emacs/ipc :jerboa-emacs/helm-commands (only-in :jerboa-emacs/editor-extra-editing tui-record-edit-position!) + (only-in :jerboa-emacs/editor-extra-media2 beacon-check-jump!) (only-in :jerboa-emacs/editor-extra-org *desktop-save-mode*) (only-in :jerboa-emacs/persist *which-key-mode* *which-key-delay* which-key-summary)) @@ -568,6 +569,9 @@ ;; Tick which-key delayed display (which-key-tui-tick! app) + ;; Beacon: check for large cursor jumps and flash + (beacon-check-jump! app) + ;; Auto-save and external modification check (~30s at 50ms poll) (set! *auto-save-counter* (+ *auto-save-counter* 1)) (when (>= *auto-save-counter* *auto-save-interval*) --- a/src/jerboa-emacs/editor-core.ss +++ b/src/jerboa-emacs/editor-core.ss @@ -36,6 +36,7 @@ (def *auto-pair-mode* #t) (def *auto-revert-mode* #f) (def *aggressive-indent-mode* #f) +(def *delete-selection-mode* #t) ;; default on, like Emacs ;;;============================================================================ ;;; Pulse/flash highlight on jump (beacon-like) @@ -473,6 +474,12 @@ (editor-goto-pos ed (+ pos 1)))))) (else (let* ((ed (current-editor app)) + ;; Delete-selection mode: if there's a selection, delete it first + (sel-start (send-message ed SCI_GETSELECTIONSTART 0 0)) + (sel-end (send-message ed SCI_GETSELECTIONEND 0 0)) + (_ (when (and *delete-selection-mode* (> sel-end sel-start)) + (send-message/string ed SCI_REPLACESEL ""))) + (pair-active (or *auto-pair-mode* *electric-pair-mode*)) (close-ch (and pair-active (if *electric-pair-mode* --- a/src/jerboa-emacs/editor-extra-final.ss +++ b/src/jerboa-emacs/editor-extra-final.ss @@ -84,10 +84,42 @@ (let ((on (toggle-mode! 'pixel-scroll))) (echo-message! (app-state-echo app) (if on "Pixel scroll: on" "Pixel scroll: off")))) +(def *so-long-threshold* 500) ;; line length threshold + +(def (so-long-detect? ed) + "Check if buffer has lines longer than threshold." + (let* ((text (editor-get-text ed)) + (len (string-length text))) + (let loop ((i 0) (line-start 0) (checked 0)) + (cond + ((>= checked 50) #f) ;; only check first 50 lines + ((>= i len) + (> (- i line-start) *so-long-threshold*)) + ((char=? (string-ref text i) #\newline) + (if (> (- i line-start) *so-long-threshold*) + #t + (loop (+ i 1) (+ i 1) (+ checked 1)))) + (else (loop (+ i 1) line-start checked)))))) + +(def (so-long-apply! ed) + "Apply so-long optimizations: disable wrap, word wrap, and syntax highlighting." + (send-message ed 2469 0 0) ;; SCI_SETWRAPMODE = SC_WRAP_NONE + (send-message ed SCI_SETLEXER 1 0) ;; SCLEX_NULL = no syntax + (send-message ed SCI_SETINDENTATIONGUIDES 0 0)) + (def (cmd-so-long-mode app) - "Toggle so-long mode for long lines — disables features on long-line files." - (let ((on (toggle-mode! 'so-long))) - (echo-message! (app-state-echo app) (if on "So-long mode: on" "So-long mode: off")))) + "Toggle so-long mode — disable slow features for long-line files." + (let* ((on (toggle-mode! 'so-long)) + (fr (app-state-frame app)) + (win (current-window fr)) + (ed (edit-window-editor win))) + (if on + (if (so-long-detect? ed) + (begin + (so-long-apply! ed) + (echo-message! (app-state-echo app) "So-long: on (long lines detected, features disabled)")) + (echo-message! (app-state-echo app) "So-long: on (no long lines found)")) + (echo-message! (app-state-echo app) "So-long: off")))) (def (cmd-repeat-mode app) "Toggle repeat-mode for transient repeat maps." @@ -100,24 +132,167 @@ "Toggle context-menu-mode — N/A in terminal." (echo-message! (app-state-echo app) "Context menu: N/A in terminal")) +(def *savehist-file* + (string-append (or (getenv "HOME" #f) ".") "/.jemacs-history")) + +;; Shared minibuffer history list (strings from echo-read-string) +(def *savehist-list* '()) + +(def (savehist-record! input) + "Record an input string in the savehist list." + (when (and (string? input) (> (string-length input) 0)) + (set! *savehist-list* + (cons input (filter (lambda (s) (not (string=? s input))) + *savehist-list*))) + (when (> (length *savehist-list*) 200) + (set! *savehist-list* (take *savehist-list* 200))))) + +(def (savehist-save!) + "Save minibuffer history to disk." + (with-exception-catcher + (lambda (e) #f) + (lambda () + (call-with-output-file *savehist-file* + (lambda (port) + (for-each (lambda (item) + (write item port) (newline port)) + *savehist-list*)))))) + +(def (savehist-load!) + "Load minibuffer history from disk." + (with-exception-catcher + (lambda (e) #f) + (lambda () + (when (file-exists? *savehist-file*) + (set! *savehist-list* + (call-with-input-file *savehist-file* + (lambda (port) + (let loop ((acc '())) + (let ((item (read port))) + (if (eof-object? item) (reverse acc) + (loop (cons item acc)))))))))))) + (def (cmd-savehist-mode app) - "Toggle savehist-mode — persist minibuffer history." + "Toggle savehist-mode — persist minibuffer history to ~/.jemacs-history." (let ((on (toggle-mode! 'savehist))) - (echo-message! (app-state-echo app) (if on "Savehist: on" "Savehist: off")))) + (if on (savehist-load!) (savehist-save!)) + (echo-message! (app-state-echo app) + (if on + (string-append "Savehist: on (" (number->string (length *savehist-list*)) " entries)") + "Savehist: off (saved)")))) + +(def *recentf-file* + (string-append (or (getenv "HOME" #f) ".") "/.jemacs-recentf")) + +(def (recentf-save!) + "Save recent files list to disk." + (with-exception-catcher + (lambda (e) #f) + (lambda () + (let ((items (if (> (length *recent-files*) 50) (take *recent-files* 50) *recent-files*))) + (call-with-output-file *recentf-file* + (lambda (port) + (for-each (lambda (path) + (write path port) (newline port)) + items))))))) + +(def (recentf-load!) + "Load recent files list from disk." + (with-exception-catcher + (lambda (e) #f) + (lambda () + (when (file-exists? *recentf-file*) + (let ((items (call-with-input-file *recentf-file* + (lambda (port) + (let loop ((acc '())) + (let ((item (read port))) + (if (eof-object? item) (reverse acc) + (loop (cons item acc))))))))) + ;; Merge loaded files with current, avoiding duplicates + (for-each + (lambda (path) + (unless (member path *recent-files*) + (set! *recent-files* (append *recent-files* (list path))))) + items)))))) (def (cmd-recentf-mode app) - "Toggle recentf-mode — track recent files." + "Toggle recentf-mode — persist recent files list to ~/.jemacs-recentf." (let ((on (toggle-mode! 'recentf))) - (echo-message! (app-state-echo app) (if on "Recentf: on" "Recentf: off")))) + (if on (recentf-load!) (recentf-save!)) + (echo-message! (app-state-echo app) + (if on + (string-append "Recentf: on (" (number->string (length *recent-files*)) " files)") + "Recentf: off (saved)")))) (def (cmd-winner-undo-2 app) "Winner undo alternative binding." (cmd-winner-undo app)) +(def *subword-mode* #f) + +(def (subword-forward-pos ed) + "Find next subword boundary position (CamelCase/underscore aware)." + (let* ((pos (editor-get-current-pos ed)) + (text (editor-get-text ed)) + (len (string-length text))) + (if (>= pos len) pos + (let loop ((i (+ pos 1))) + (cond + ((>= i len) i) + ;; Stop at transitions: lower→upper, letter→non-alphanum, non-alphanum→letter + ((and (> i (+ pos 1)) + (let ((c (string-ref text i)) + (p (string-ref text (- i 1)))) + (or (and (char-lower-case? p) (char-upper-case? c)) + (and (char-alphabetic? p) (char=? c #\_)) + (and (char=? p #\_) (char-alphabetic? c)) + (and (char-alphabetic? p) (not (char-alphabetic? c)) (not (char=? c #\_))) + (and (not (char-alphabetic? p)) (not (char=? p #\_)) (char-alphabetic? c))))) + i) + (else (loop (+ i 1)))))))) + +(def (subword-backward-pos ed) + "Find previous subword boundary position." + (let* ((pos (editor-get-current-pos ed)) + (text (editor-get-text ed))) + (if (<= pos 0) 0 + (let loop ((i (- pos 1))) + (cond + ((< i 1) 0) + ((let ((c (string-ref text i)) + (p (string-ref text (- i 1)))) + (or (and (char-upper-case? c) (char-lower-case? p)) + (and (char-alphabetic? c) (char=? p #\_)) + (and (char=? c #\_) (char-alphabetic? p)) + (and (char-alphabetic? c) (not (char-alphabetic? p)) (not (char=? p #\_))))) + i) + (else (loop (- i 1)))))))) + +(def (cmd-subword-forward app) + "Move forward one subword (CamelCase-aware)." + (let ((ed (edit-window-editor (current-window (app-state-frame app))))) + (editor-goto-pos ed (subword-forward-pos ed)))) + +(def (cmd-subword-backward app) + "Move backward one subword (CamelCase-aware)." + (let ((ed (edit-window-editor (current-window (app-state-frame app))))) + (editor-goto-pos ed (subword-backward-pos ed)))) + +(def (cmd-subword-kill app) + "Kill forward one subword." + (let* ((ed (edit-window-editor (current-window (app-state-frame app)))) + (start (editor-get-current-pos ed)) + (end (subword-forward-pos ed))) + (when (> end start) + (send-message ed SCI_SETTARGETSTART start 0) + (send-message ed SCI_SETTARGETEND end 0) + (send-message/string ed SCI_REPLACETARGET "")))) + (def (cmd-global-subword-mode app) "Toggle global subword-mode (CamelCase navigation)." - (let ((on (toggle-mode! 'global-subword))) - (echo-message! (app-state-echo app) (if on "Global subword: on" "Global subword: off")))) + (set! *subword-mode* (not *subword-mode*)) + (echo-message! (app-state-echo app) + (if *subword-mode* "Subword mode: on (use M-x subword-forward/backward)" "Subword mode: off"))) (def (cmd-display-fill-column-indicator-mode app) "Toggle fill column indicator display." --- a/src/jerboa-emacs/editor-extra-media2.ss +++ b/src/jerboa-emacs/editor-extra-media2.ss @@ -14,7 +14,7 @@ :chez-scintilla/tui :jerboa-emacs/core (only-in :jerboa-emacs/editor-core - *auto-save-enabled* make-auto-save-path) + *auto-save-enabled* make-auto-save-path pulse-line!) :jerboa-emacs/keymap :jerboa-emacs/buffer :jerboa-emacs/window @@ -1672,9 +1672,30 @@ (def *beacon-mode* #f) +(def *beacon-last-line* 0) + +(def (beacon-check-jump! app) + "Check if cursor moved a large distance and flash if beacon mode is on." + (when *beacon-mode* + (let* ((fr (app-state-frame app)) + (win (current-window fr)) + (ed (edit-window-editor win)) + (pos (editor-get-current-pos ed)) + (cur-line (editor-line-from-position ed pos)) + (delta (abs (- cur-line *beacon-last-line*)))) + (set! *beacon-last-line* cur-line) + ;; Flash if jumped more than 3 lines + (when (> delta 3) + (pulse-line! ed cur-line))))) + (def (cmd-beacon-mode app) "Toggle beacon mode — flash cursor position after large jumps." (set! *beacon-mode* (not *beacon-mode*)) + (when *beacon-mode* + ;; Initialize last line + (let* ((ed (edit-window-editor (current-window (app-state-frame app)))) + (pos (editor-get-current-pos ed))) + (set! *beacon-last-line* (editor-line-from-position ed pos)))) (echo-message! (app-state-echo app) (if *beacon-mode* "Beacon mode ON" "Beacon mode OFF"))) @@ -1746,9 +1767,34 @@ (def *tui-dimmer-mode* #f) +(def (dimmer-apply! app) + "Apply dimmer effect: active window full brightness, others dimmed." + (let* ((fr (app-state-frame app)) + (cur-idx (frame-current-idx fr)) + (wins (frame-windows fr))) + (let loop ((ws wins) (i 0)) + (when (pair? ws) + (let ((ed (edit-window-editor (car ws)))) + (if (= i cur-idx) + ;; Active window: full alpha + (send-message ed SCI_SETELEMENTCOLOUR 52 #xFF000000) ;; SC_ELEMENT_WHITE_SPACE_BACK + ;; Inactive: darken background by reducing brightness + (send-message ed SCI_SETELEMENTCOLOUR 52 #x40111111))) + (loop (cdr ws) (+ i 1)))))) + +(def (dimmer-clear! app) + "Remove dimmer effect from all windows." + (for-each + (lambda (win) + (send-message (edit-window-editor win) SCI_SETELEMENTCOLOUR 52 #xFF000000)) + (frame-windows (app-state-frame app)))) + (def (cmd-dimmer-mode app) "Toggle dimmer mode — dim non-active windows." (set! *tui-dimmer-mode* (not *tui-dimmer-mode*)) + (if *tui-dimmer-mode* + (dimmer-apply! app) + (dimmer-clear! app)) (echo-message! (app-state-echo app) (if *tui-dimmer-mode* "Dimmer mode enabled" "Dimmer mode disabled"))) @@ -1783,18 +1829,31 @@ (def *tui-centered-cursor* #f) +(def (centered-cursor-apply! app) + "Apply centered cursor policy to all windows when mode is on." + (when *tui-centered-cursor* + (for-each + (lambda (win) + (let* ((ed (edit-window-editor win)) + (pos (editor-get-current-pos ed)) + (cur-line (editor-line-from-position ed pos)) + (visible-lines (max 1 (- (edit-window-h win) 1))) + (target (max 0 (- cur-line (quotient visible-lines 2))))) + ;; SCI_SETYCARETPOLICY: CARET_STRICT | CARET_EVEN = 13, with slop = half screen + (send-message ed 2403 13 (quotient visible-lines 2)))) + (frame-windows (app-state-frame app))))) + (def (cmd-centered-cursor-mode app) "Toggle centered cursor mode — keep cursor vertically centered." (set! *tui-centered-cursor* (not *tui-centered-cursor*)) - (when *tui-centered-cursor* - (let* ((fr (app-state-frame app)) - (win (current-window fr)) - (ed (edit-window-editor win)) - (pos (editor-get-current-pos ed)) - (cur-line (editor-line-from-position ed pos)) - (visible-lines (max 1 (- (edit-window-h win) 1))) - (target (max 0 (- cur-line (quotient visible-lines 2))))) - (send-message ed SCI_SETFIRSTVISIBLELINE target 0))) + (let ((fr (app-state-frame app))) + (if *tui-centered-cursor* + (centered-cursor-apply! app) + ;; Restore default caret policy: CARET_EVEN = 8 + (for-each + (lambda (win) + (send-message (edit-window-editor win) 2403 8 0)) + (frame-windows fr)))) (echo-message! (app-state-echo app) (if *tui-centered-cursor* "Centered cursor mode enabled" "Centered cursor mode disabled"))) --- a/src/jerboa-emacs/editor-extra-modes.ss +++ b/src/jerboa-emacs/editor-extra-modes.ss @@ -690,10 +690,83 @@ (echo-message! (app-state-echo app) (if on "Eldoc mode: on" "Eldoc mode: off")))) ;; Which-function extras +(def *which-function-name* "") + +(def (which-function-update! app) + "Update the current function name (called from tick loop when mode is on)." + (when (mode-enabled? 'which-function) + (let* ((fr (app-state-frame app)) + (win (current-window fr)) + (ed (edit-window-editor win)) + (pos (editor-get-current-pos ed)) + (text (editor-get-text ed)) + (line (send-message ed 2166 pos 0))) ;; SCI_LINEFROMPOSITION + ;; Search backward for function definition + (let loop ((l line)) + (if (< l 0) + (set! *which-function-name* "") + (let* ((ls (send-message ed 2167 l 0)) ;; SCI_POSITIONFROMLINE + (le (send-message ed 2136 l 0)) ;; SCI_GETLINEENDPOSITION + (lt (if (and (>= ls 0) (<= le (string-length text))) + (substring text ls (min le (string-length text))) "")) + (name (which-function-find-name lt))) + (if name + (set! *which-function-name* name) + (loop (- l 1))))))))) + +(def (which-function-find-name line-text) + "Extract function/def name from a line of code." + (let ((t (string-trim line-text))) + (cond + ;; Scheme: (def (name or (define (name + ((or (string-contains t "(def (") (string-contains t "(define (")) + (let* ((idx (or (string-contains t "(def (") (string-contains t "(define ("))) + (skip (if (string-contains t "(define (") 9 6)) + (start (+ idx skip)) + (end (let loop ((j start)) + (if (or (>= j (string-length t)) + (memv (string-ref t j) '(#\space #\) #\( #\tab))) + j (loop (+ j 1)))))) + (if (> end start) (substring t start end) #f))) + ;; Python: def name( or class name + ((or (string-prefix? "def " t) (string-prefix? "class " t)) + (let* ((start (if (string-prefix? "class " t) 6 4)) + (end (let loop ((j start)) + (if (or (>= j (string-length t)) + (memv (string-ref t j) '(#\( #\: #\space))) + j (loop (+ j 1)))))) + (if (> end start) (substring t start end) #f))) + ;; C/Go/Rust: func/fn name + ((or (string-prefix? "func " t) (string-prefix? "fn " t)) + (let* ((skip (if (string-prefix? "fn " t) 3 5)) + (end (let loop ((j skip)) + (if (or (>= j (string-length t)) + (memv (string-ref t j) '(#\( #\space #\{ #\<))) + j (loop (+ j 1)))))) + (if (> end skip) (substring t skip end) #f))) + ;; JS/TS: function name( + ((string-prefix? "function " t) + (let* ((start 9) + (end (let loop ((j start)) + (if (or (>= j (string-length t)) + (memv (string-ref t j) '(#\( #\space #\{))) + j (loop (+ j 1)))))) + (if (> end start) (substring t start end) #f))) + (else #f)))) + (def (cmd-which-function-mode app) - "Toggle which-function mode — shows current function name." + "Toggle which-function mode — shows current function name in echo area." (let ((on (toggle-mode! 'which-function))) - (echo-message! (app-state-echo app) (if on "Which-function mode: on" "Which-function mode: off")))) + (if on + (begin + (which-function-update! app) + (echo-message! (app-state-echo app) + (if (string-empty? *which-function-name*) + "Which-function mode: on (not in a function)" + (string-append "Which-function mode: on [" *which-function-name* "]")))) + (begin + (set! *which-function-name* "") + (echo-message! (app-state-echo app) "Which-function mode: off"))))) ;; Compilation (def (cmd-compilation-mode app) --- a/src/jerboa-emacs/editor-extra-regs2.ss +++ b/src/jerboa-emacs/editor-extra-regs2.ss @@ -1388,4 +1388,10 @@ ;; Perspective management (register-command! 'persp-list cmd-persp-list) (register-command! 'persp-kill cmd-persp-kill) + ;; Round 2 features: savehist, so-long, prettify-symbols, which-function, recentf + (register-command! 'savehist-mode cmd-savehist-mode) + (register-command! 'so-long-mode cmd-so-long-mode) + (register-command! 'prettify-symbols-mode cmd-toggle-global-prettify) + (register-command! 'which-function-mode cmd-which-function-mode) + (register-command! 'recentf-mode cmd-recentf-mode) ) --- a/src/jerboa-emacs/editor-extra-tools2.ss +++ b/src/jerboa-emacs/editor-extra-tools2.ss @@ -658,11 +658,70 @@ (cmd-which-key app)) ;; Programming helpers +(def *prettify-symbols-table* + '(("lambda" . "\x03BB;") ;; λ + ("->" . "\x2192;") ;; → + ("=>" . "\x21D2;") ;; ⇒ + ("<-" . "\x2190;") ;; ← + ("!=" . "\x2260;") ;; ≠ + (">=" . "\x2265;") ;; ≥ + ("<=" . "\x2264;") ;; ≤ + ("alpha" . "\x03B1;") ;; α + ("beta" . "\x03B2;") ;; β + ("gamma" . "\x03B3;") ;; γ + ("delta" . "\x03B4;") ;; δ + ("pi" . "\x03C0;") ;; π + ("nil" . "\x2205;") ;; ∅ + ("..." . "\x2026;") ;; … + ("not" . "\x00AC;") ;; ¬ + ("and" . "\x2227;") ;; ∧ + ("or" . "\x2228;"))) ;; ∨ + +(def *prettify-indicator* 9) + +(def (prettify-symbols-apply! ed) + "Scan buffer and highlight symbol keywords with indicator 9." + (let ((text (editor-get-text ed)) + (len (send-message ed SCI_GETTEXTLENGTH 0 0))) + ;; Clear existing + (send-message ed SCI_SETINDICATORCURRENT *prettify-indicator* 0) + (send-message ed SCI_INDICATORCLEARRANGE 0 len) + ;; Setup indicator style: text color substitution + (send-message ed SCI_INDICSETSTYLE *prettify-indicator* 6) ;; INDIC_BOX + (send-message ed SCI_INDICSETFORE *prettify-indicator* #x888888) + ;; Find and mark each symbol + (for-each + (lambda (pair) + (let* ((sym (car pair)) + (slen (string-length sym)) + (text-lower (string-downcase text))) + (let loop ((start 0)) + (let ((pos (string-contains text-lower (string-downcase sym) start))) + (when pos + ;; Check word boundaries (don't match partial words) + (let ((before-ok (or (= pos 0) + (not (char-alphabetic? (string-ref text (- pos 1)))))) + (after-ok (or (>= (+ pos slen) (string-length text)) + (not (char-alphabetic? (string-ref text (+ pos slen))))))) + (when (and before-ok after-ok) + (send-message ed SCI_SETINDICATORCURRENT *prettify-indicator* 0) + (send-message ed SCI_INDICATORFILLRANGE pos slen))) + (loop (+ pos slen))))))) + *prettify-symbols-table*))) + (def (cmd-toggle-prettify-symbols app) - "Toggle prettify-symbols mode." - (let ((on (toggle-mode! 'prettify-symbols))) - (echo-message! (app-state-echo app) - (if on "Prettify-symbols enabled" "Prettify-symbols disabled")))) + "Toggle prettify-symbols mode — highlight symbol keywords." + (let* ((on (toggle-mode! 'prettify-symbols)) + (ed (edit-window-editor (current-window (app-state-frame app))))) + (if on + (begin + (prettify-symbols-apply! ed) + (echo-message! (app-state-echo app) "Prettify-symbols enabled")) + (begin + (let ((len (send-message ed SCI_GETTEXTLENGTH 0 0))) + (send-message ed SCI_SETINDICATORCURRENT *prettify-indicator* 0) + (send-message ed SCI_INDICATORCLEARRANGE 0 len)) + (echo-message! (app-state-echo app) "Prettify-symbols disabled"))))) (def (cmd-subword-mode app) "Toggle subword mode for CamelCase-aware navigation." --- a/src/jerboa-emacs/editor-extra-vcs.ss +++ b/src/jerboa-emacs/editor-extra-vcs.ss @@ -17,7 +17,8 @@ :jerboa-emacs/window :jerboa-emacs/modeline :jerboa-emacs/echo - :jerboa-emacs/editor-extra-helpers) + :jerboa-emacs/editor-extra-helpers + (only-in :jerboa-emacs/editor-core *delete-selection-mode*)) ;; Additional VC commands (def (cmd-vc-register app) @@ -1403,7 +1404,7 @@ ;;; --- Toggle delete-selection mode (typing replaces selection) --- -(def *delete-selection-mode* #t) +;; *delete-selection-mode* is defined in editor-core.ss (def (cmd-toggle-delete-selection app) "Toggle delete-selection mode (typing replaces active selection)."