conversions
ober
45b3dc7c8b9afc0d9182502044ec6f23ad0ef11e
new file mode 100644 --- /dev/null +++ b/lib/jerboa-emacs/editor-advanced.sls @@ -0,0 +1,2167 @@ +#!chezscheme +;;; editor-advanced.sls — Advanced commands for jemacs +;;; +;;; Ported from gerbil-emacs/editor-advanced.ss +;;; Misc navigation, where-is, apropos, universal argument, text transforms, +;;; hex dump, diff, checksum, eval buffer, ediff, calculator, modes, +;;; hippie expand. + +(library (jerboa-emacs editor-advanced) + (export + ;; Misc navigation + cmd-exchange-point-and-mark + cmd-mark-whole-buffer + cmd-recenter-top-bottom + cmd-what-page + cmd-count-lines-region + cmd-copy-line + + ;; Help: where-is, apropos + cmd-where-is + cmd-apropos-command + + ;; Buffer: toggle-read-only, rename + cmd-toggle-read-only + cmd-rename-buffer + + ;; Other-window commands + cmd-switch-buffer-other-window + cmd-find-file-other-window + + ;; Universal argument + cmd-universal-argument + cmd-digit-argument + cmd-negative-argument + cmd-digit-argument-0 cmd-digit-argument-1 cmd-digit-argument-2 + cmd-digit-argument-3 cmd-digit-argument-4 cmd-digit-argument-5 + cmd-digit-argument-6 cmd-digit-argument-7 cmd-digit-argument-8 + cmd-digit-argument-9 + + ;; Text transforms + cmd-tabify + cmd-untabify + cmd-base64-encode-region + cmd-base64-decode-region + rot13-char rot13-string + cmd-rot13-region + + ;; Hex dump + cmd-hexl-mode + + ;; Count matches, delete duplicate lines + cmd-count-matches + cmd-delete-duplicate-lines + + ;; Diff buffer with file + cmd-diff-buffer-with-file + + ;; Checksum + cmd-checksum + + ;; Async shell command + cmd-async-shell-command + + ;; Toggle truncate lines + cmd-toggle-truncate-lines + + ;; Grep in buffer + cmd-grep-buffer + + ;; Insert date/char + cmd-insert-date + cmd-insert-char + + ;; Eval buffer/region + cmd-eval-buffer + cmd-eval-region + + ;; Clone/scratch buffer + cmd-clone-buffer + cmd-scratch-buffer + + ;; Save some buffers + cmd-save-some-buffers + + ;; Revert buffer quick + cmd-revert-buffer-quick + + ;; Toggle highlighting + cmd-toggle-highlighting + + ;; Misc utility + cmd-view-lossage + cmd-display-time + cmd-pwd + + ;; Ediff + cmd-ediff-buffers + + ;; Calculator + cmd-calc + + ;; Toggle case-fold-search + cmd-toggle-case-fold-search + + ;; Describe bindings + cmd-describe-bindings + + ;; Center line + cmd-center-line + + ;; What face + cmd-what-face + + ;; List processes + cmd-list-processes + + ;; Message log + log-message! + cmd-view-messages + + ;; View errors/output + cmd-view-errors + cmd-view-output + + ;; Auto-fill mode + cmd-toggle-auto-fill + + ;; Rename/delete file and buffer + cmd-rename-file-and-buffer + cmd-delete-file-and-buffer + + ;; Sudo + cmd-sudo-write + cmd-sudo-edit + + ;; Sort numeric + cmd-sort-numeric + + ;; Word count + cmd-count-words-region + + ;; Overwrite mode + cmd-toggle-overwrite-mode + + ;; Visual line mode + cmd-toggle-visual-line-mode + + ;; Set fill column + cmd-set-fill-column + + ;; Fill column indicator + cmd-toggle-fill-column-indicator + + ;; Debug on error + cmd-toggle-debug-on-error + + ;; Repeat complex command + cmd-repeat-complex-command + + ;; Eldoc + cmd-eldoc + + ;; Highlight symbol + cmd-highlight-symbol + cmd-clear-highlight + + ;; Indent rigidly + cmd-indent-rigidly-right + cmd-indent-rigidly-left + + ;; Goto first/last non-blank + cmd-goto-first-non-blank + cmd-goto-last-non-blank + + ;; Buffer stats + cmd-buffer-stats + + ;; Toggle show tabs/eol + cmd-toggle-show-tabs + cmd-toggle-show-eol + + ;; Copy from above/below + cmd-copy-from-above + cmd-copy-from-below + + ;; Open line above + cmd-open-line-above + + ;; Select line + cmd-select-line + + ;; Split line + cmd-split-line + + ;; Convert line endings + cmd-convert-to-unix + cmd-convert-to-dos + + ;; Enlarge/shrink window + cmd-enlarge-window + cmd-shrink-window + + ;; What encoding + cmd-what-encoding + + ;; Hippie expand + cmd-hippie-expand + + ;; Swap buffers + cmd-swap-buffers + + ;; Tab width/indent + cmd-cycle-tab-width + cmd-toggle-indent-tabs-mode + + ;; Buffer info + cmd-buffer-info) + + (import (except (chezscheme) make-hash-table hash-table? iota 1+ 1- sort sort!) + (jerboa core) + (jerboa runtime) + (only (jerboa prelude) path-strip-directory) + (only (std srfi srfi-13) string-join string-contains string-prefix? string-trim string-trim-both) + (only (std misc string) string-split) + (std misc process) + (chez-scintilla constants) + (chez-scintilla scintilla) + (chez-scintilla style) + (chez-scintilla tui) + (jerboa-emacs core) + (jerboa-emacs repl) + (jerboa-emacs eshell) + (jerboa-emacs shell) + (jerboa-emacs keymap) + (jerboa-emacs buffer) + (jerboa-emacs window) + (jerboa-emacs modeline) + (jerboa-emacs echo) + (jerboa-emacs highlight) + (jerboa-emacs persist) + (jerboa-emacs editor-core) + (jerboa-emacs editor-ui) + (jerboa-emacs editor-text)) + + ;;;========================================================================= + ;;; Mutable state (not exported — modified via set!) + ;;;========================================================================= + + (define *case-fold-search* #t) + (define *message-log* '()) + (define *message-log-max* 100) + (define *overwrite-mode* #f) + (define *visual-line-mode* #f) + (define *fill-column-indicator* #f) + (define *debug-on-error* #f) + (define *last-mx-command* #f) + (define *show-tabs* #f) + (define *show-eol* #f) + + ;;;========================================================================= + ;;; Stubs for base64 / hex / sha256 + ;;;========================================================================= + + (define (base64-encode s) + ;; Stub — base64 not yet ported + (string-append "[base64:" s "]")) + + (define (base64-decode s) + ;; Stub — base64 not yet ported + s) + + (define (sha256-stub bv) + ;; Stub — sha256 not yet ported; return a dummy bytevector + (make-bytevector 32 0)) + + (define (hex-encode bv) + ;; Simple hex-encode for bytevectors + (let loop ((i 0) (acc '())) + (if (>= i (bytevector-length bv)) + (apply string-append (reverse acc)) + (let* ((b (bytevector-u8-ref bv i)) + (h (number->string b 16)) + (padded (if (< b 16) (string-append "0" h) h))) + (loop (+ i 1) (cons padded acc)))))) + + ;;;========================================================================= + ;;; Misc navigation commands + ;;;========================================================================= + + (define (cmd-exchange-point-and-mark app) + (let* ((ed (current-editor app)) + (buf (current-buffer-from-app app)) + (mark (buffer-mark buf))) + (if (not mark) + (echo-error! (app-state-echo app) "No mark set") + (let ((pos (editor-get-current-pos ed))) + (buffer-mark-set! buf pos) + (editor-goto-pos ed mark) + (echo-message! (app-state-echo app) "Mark and point exchanged"))))) + + (define (cmd-mark-whole-buffer app) + (cmd-select-all app)) + + (define (cmd-recenter-top-bottom app) + (editor-scroll-caret (current-editor app))) + + (define (cmd-what-page app) + (let* ((ed (current-editor app)) + (pos (editor-get-current-pos ed)) + (text (editor-get-text ed)) + (line (editor-line-from-position ed pos)) + (pages + (let loop ((i 0) (count 1)) + (if (>= i pos) count + (if (char=? (string-ref text i) #\page) + (loop (+ i 1) (+ count 1)) + (loop (+ i 1) count)))))) + (echo-message! (app-state-echo app) + (string-append "Page " (number->string pages) + ", Line " (number->string (+ line 1)))))) + + (define (cmd-count-lines-region app) + (let* ((ed (current-editor app)) + (buf (current-buffer-from-app app)) + (mark (buffer-mark buf))) + (if (not mark) + (echo-error! (app-state-echo app) "No region") + (let* ((pos (editor-get-current-pos ed)) + (start (min mark pos)) + (end (max mark pos)) + (start-line (editor-line-from-position ed start)) + (end-line (editor-line-from-position ed end)) + (lines (+ (- end-line start-line) 1)) + (chars (- end start))) + (echo-message! (app-state-echo app) + (string-append "Region has " (number->string lines) + " lines, " (number->string chars) " chars")))))) + + (define (cmd-copy-line app) + (let* ((ed (current-editor app)) + (pos (editor-get-current-pos ed)) + (line (editor-line-from-position ed pos)) + (line-start (editor-position-from-line ed line)) + (line-end (editor-get-line-end-position ed line)) + (text (editor-get-text ed)) + (total (editor-get-line-count ed)) + ;; Include newline if not last line + (end (if (< (+ line 1) total) + (editor-position-from-line ed (+ line 1)) + line-end)) + (line-text (substring text line-start end))) + (app-state-kill-ring-set! app + (cons line-text (app-state-kill-ring app))) + (echo-message! (app-state-echo app) "Line copied"))) + + ;;;========================================================================= + ;;; Help: where-is, apropos-command + ;;;========================================================================= + + (define (cmd-where-is app) + (let* ((echo (app-state-echo app)) + (fr (app-state-frame app)) + (row (- (frame-height fr) 1)) + (width (frame-width fr)) + (input (echo-read-string echo "Where is command: " row width))) + (if (not input) + (echo-message! echo "Cancelled") + (let* ((cmd-name (string->symbol input)) + (found '())) + ;; Search global keymap + (for-each + (lambda (entry) + (let ((key (car entry)) + (val (cdr entry))) + (cond + ((eq? val cmd-name) + (set! found (cons key found))) + ((hash-table? val) + ;; Search prefix map + (for-each + (lambda (sub) + (when (eq? (cdr sub) cmd-name) + (set! found (cons (string-append key " " (car sub)) found)))) + (keymap-entries val)))))) + (keymap-entries *global-keymap*)) + (if (null? found) + (echo-message! echo (string-append input " is not on any key")) + (echo-message! echo + (string-append input " is on " + (string-join (reverse found) ", ")))))))) + + (define (cmd-apropos-command app) + (let* ((echo (app-state-echo app)) + (fr (app-state-frame app)) + (row (- (frame-height fr) 1)) + (width (frame-width fr)) + (input (echo-read-string echo "Apropos command: " row width))) + (if (not input) + (echo-message! echo "Cancelled") + (let ((matches '())) + ;; Search all registered commands + (hash-for-each + (lambda (name _proc) + (when (string-contains (symbol->string name) input) + (set! matches (cons (symbol->string name) matches)))) + *all-commands*) + (if (null? matches) + (echo-message! echo (string-append "No commands matching '" input "'")) + (let* ((sorted (list-sort string<? matches)) + (text (string-append "Commands matching '" input "':\n\n" + (string-join sorted "\n") "\n"))) + ;; Show in *Help* buffer + (let* ((ed (current-editor app)) + (buf (or (buffer-by-name "*Help*") + (buffer-create! "*Help*" ed #f)))) + (buffer-attach! ed buf) + (edit-window-buffer-set! (current-window fr) buf) + (editor-set-text ed text) + (editor-set-save-point ed) + (editor-goto-pos ed 0) + (echo-message! echo + (string-append (number->string (length sorted)) + " commands match"))))))))) + + ;;;========================================================================= + ;;; Buffer: toggle-read-only, rename-buffer + ;;;========================================================================= + + (define (cmd-toggle-read-only app) + (let* ((ed (current-editor app)) + (readonly? (editor-get-read-only? ed))) + (editor-set-read-only ed (not readonly?)) + (echo-message! (app-state-echo app) + (if readonly? "Buffer is now writable" "Buffer is now read-only")))) + + (define (cmd-rename-buffer app) + (let* ((echo (app-state-echo app)) + (fr (app-state-frame app)) + (row (- (frame-height fr) 1)) + (width (frame-width fr)) + (buf (current-buffer-from-app app)) + (old-name (buffer-name buf)) + (new-name (echo-read-string echo + (string-append "Rename buffer (was " old-name "): ") + row width))) + (if (not new-name) + (echo-message! echo "Cancelled") + (if (string=? new-name "") + (echo-error! echo "Name cannot be empty") + (begin + (buffer-name-set! buf new-name) + (echo-message! echo + (string-append "Renamed to " new-name))))))) + + ;;;========================================================================= + ;;; Other-window commands + ;;;========================================================================= + + (define (cmd-switch-buffer-other-window app) + (let* ((echo (app-state-echo app)) + (fr (app-state-frame app)) + (wins (frame-windows fr))) + (if (<= (length wins) 1) + (begin + (cmd-split-window app) + (frame-other-window! fr) + (cmd-switch-buffer app)) + (begin + (frame-other-window! fr) + (cmd-switch-buffer app))))) + + (define (cmd-find-file-other-window app) + (let* ((fr (app-state-frame app)) + (wins (frame-windows fr))) + (if (<= (length wins) 1) + (begin + (cmd-split-window app) + (frame-other-window! fr) + (cmd-find-file app)) + (begin + (frame-other-window! fr) + (cmd-find-file app))))) + + ;;;========================================================================= + ;;; Universal argument (C-u) + ;;;========================================================================= + + (define (cmd-universal-argument app) + (let ((current (app-state-prefix-arg app))) + (cond + ((not current) + (app-state-prefix-arg-set! app '(4))) + ((list? current) + (app-state-prefix-arg-set! app (list (* 4 (car current))))) + (else + (app-state-prefix-arg-set! app '(4)))) + (echo-message! (app-state-echo app) + (string-append "C-u" + (let ((val (car (app-state-prefix-arg app)))) + (if (= val 4) "" (string-append " " (number->string val)))) + "-")))) + + (define (cmd-digit-argument app digit) + (let ((current (app-state-prefix-arg app))) + (cond + ((number? current) + (app-state-prefix-arg-set! app (+ (* current 10) digit))) + ((eq? current '-) + (app-state-prefix-arg-set! app (- digit))) + (else + (app-state-prefix-arg-set! app digit))) + (app-state-prefix-digit-mode?-set! app #t) + (echo-message! (app-state-echo app) + (string-append "Arg: " (if (eq? (app-state-prefix-arg app) '-) + "-" + (number->string (app-state-prefix-arg app))))))) + + (define (cmd-negative-argument app) + (app-state-prefix-arg-set! app '-) + (app-state-prefix-digit-mode?-set! app #t) + (echo-message! (app-state-echo app) "Arg: -")) + + ;; Individual digit argument commands for registry + (define (cmd-digit-argument-0 app) (cmd-digit-argument app 0)) + (define (cmd-digit-argument-1 app) (cmd-digit-argument app 1)) + (define (cmd-digit-argument-2 app) (cmd-digit-argument app 2)) + (define (cmd-digit-argument-3 app) (cmd-digit-argument app 3)) + (define (cmd-digit-argument-4 app) (cmd-digit-argument app 4)) + (define (cmd-digit-argument-5 app) (cmd-digit-argument app 5)) + (define (cmd-digit-argument-6 app) (cmd-digit-argument app 6)) + (define (cmd-digit-argument-7 app) (cmd-digit-argument app 7)) + (define (cmd-digit-argument-8 app) (cmd-digit-argument app 8)) + (define (cmd-digit-argument-9 app) (cmd-digit-argument app 9)) + + ;;;========================================================================= + ;;; Text transforms: tabify, untabify, base64, rot13 + ;;;========================================================================= + + (define (cmd-tabify app) + (let* ((ed (current-editor app)) + (echo (app-state-echo app)) + (buf (current-buffer-from-app app)) + (mark (buffer-mark buf)) + (text (editor-get-text ed))) + (let-values (((start end) + (if mark + (let ((pos (editor-get-current-pos ed))) + (values (min mark pos) (max mark pos))) + (values 0 (string-length text))))) + (let* ((region (substring text start end)) + ;; Replace runs of 8 spaces with tab + (result (let loop ((s region) (acc "")) + (let ((idx (string-contains s " "))) ; 8 spaces + (if idx + (loop (substring s (+ idx 8) (string-length s)) + (string-append acc (substring s 0 idx) "\t")) + (string-append acc s)))))) + (with-undo-action ed + (editor-delete-range ed start (- end start)) + (editor-insert-text ed start result)) + (when mark (buffer-mark-set! buf #f)) + (echo-message! echo "Tabified"))))) + + (define (cmd-untabify app) + (let* ((ed (current-editor app)) + (echo (app-state-echo app)) + (buf (current-buffer-from-app app)) + (mark (buffer-mark buf)) + (text (editor-get-text ed))) + (let-values (((start end) + (if mark + (let ((pos (editor-get-current-pos ed))) + (values (min mark pos) (max mark pos))) + (values 0 (string-length text))))) + (let* ((region (substring text start end)) + ;; Replace all tabs with 8 spaces + (result (let loop ((i 0) (acc '())) + (if (>= i (string-length region)) + (apply string-append (reverse acc)) + (if (char=? (string-ref region i) #\tab) + (loop (+ i 1) (cons " " acc)) + (loop (+ i 1) (cons (string (string-ref region i)) acc))))))) + (with-undo-action ed + (editor-delete-range ed start (- end start)) + (editor-insert-text ed start result)) + (when mark (buffer-mark-set! buf #f)) + (echo-message! echo "Untabified"))))) + + (define (cmd-base64-encode-region app) + (let* ((ed (current-editor app)) + (echo (app-state-echo app)) + (buf (current-buffer-from-app app)) + (mark (buffer-mark buf))) + (if (not mark) + (echo-error! echo "No region (set mark first)") + (let* ((pos (editor-get-current-pos ed)) + (start (min mark pos)) + (end (max mark pos)) + (region (substring (editor-get-text ed) start end)) + (encoded (base64-encode region))) + (with-undo-action ed + (editor-delete-range ed start (- end start)) + (editor-insert-text ed start encoded)) + (buffer-mark-set! buf #f) + (echo-message! echo "Base64 encoded"))))) + + (define (cmd-base64-decode-region app) + (let* ((ed (current-editor app)) + (echo (app-state-echo app)) + (buf (current-buffer-from-app app)) + (mark (buffer-mark buf))) + (if (not mark) + (echo-error! echo "No region (set mark first)") + (guard (e [#t (echo-error! echo "Base64 decode error")]) + (let* ((pos (editor-get-current-pos ed)) + (start (min mark pos)) + (end (max mark pos)) + (region (substring (editor-get-text ed) start end)) + (decoded (base64-decode (string-trim-both region)))) + (with-undo-action ed + (editor-delete-range ed start (- end start)) + (editor-insert-text ed start decoded)) + (buffer-mark-set! buf #f) + (echo-message! echo "Base64 decoded")))))) + + (define (rot13-char ch) + (cond + ((and (char>=? ch #\a) (char<=? ch #\z)) + (integer->char (+ (char->integer #\a) + (modulo (+ (- (char->integer ch) (char->integer #\a)) 13) 26)))) + ((and (char>=? ch #\A) (char<=? ch #\Z)) + (integer->char (+ (char->integer #\A) + (modulo (+ (- (char->integer ch) (char->integer #\A)) 13) 26)))) + (else ch))) + + (define (rot13-string s) + (let* ((len (string-length s)) + (result (make-string len))) + (let loop ((i 0)) + (when (< i len) + (string-set! result i (rot13-char (string-ref s i))) + (loop (+ i 1)))) + result)) + + (define (cmd-rot13-region app) + (let* ((ed (current-editor app)) + (echo (app-state-echo app)) + (buf (current-buffer-from-app app)) + (mark (buffer-mark buf)) + (text (editor-get-text ed))) + (let-values (((start end) + (if mark + (let ((pos (editor-get-current-pos ed))) + (values (min mark pos) (max mark pos))) + (values 0 (string-length text))))) + (let* ((region (substring text start end)) + (result (rot13-string region))) + (with-undo-action ed + (editor-delete-range ed start (- end start)) + (editor-insert-text ed start result)) + (when mark (buffer-mark-set! buf #f)) + (echo-message! echo "ROT13 applied"))))) + + ;;;========================================================================= + ;;; Hex dump display + ;;;========================================================================= + + (define (cmd-hexl-mode app) + (let* ((ed (current-editor app)) + (echo (app-state-echo app)) + (fr (app-state-frame app)) + (text (editor-get-text ed)) + (bytes (string->utf8 text)) + (len (bytevector-length bytes)) + (lines '())) + ;; Format hex dump, 16 bytes per line + (let loop ((offset 0)) + (when (< offset len) + (let* ((end (min (+ offset 16) len)) + (hex-parts '()) + (ascii-parts '())) + ;; Hex portion + (let hex-loop ((i offset)) + (when (< i end) + (let* ((b (bytevector-u8-ref bytes i)) + (h (number->string b 16))) + (set! hex-parts + (cons (if (< b 16) (string-append "0" h) h) + hex-parts))) + (hex-loop (+ i 1)))) + ;; ASCII portion + (let ascii-loop ((i offset)) + (when (< i end) + (let ((b (bytevector-u8-ref bytes i))) + (set! ascii-parts + (cons (if (and (>= b 32) (<= b 126)) + (string (integer->char b)) + ".") + ascii-parts))) + (ascii-loop (+ i 1)))) + ;; Format offset + (let* ((off-str (number->string offset 16)) + (off-padded (string-append + (make-string (max 0 (- 8 (string-length off-str))) #\0) + off-str)) + (hex-str (string-join (reverse hex-parts) " ")) + ;; Pad hex to consistent width (47 chars for 16 bytes) + (hex-padded (string-append hex-str + (make-string (max 0 (- 47 (string-length hex-str))) #\space))) + (ascii-str (apply string-append (reverse ascii-parts)))) + (set! lines + (cons (string-append off-padded " " hex-padded " |" ascii-str "|") + lines)))) + (loop (+ offset 16)))) + ;; Display in *Hex* buffer + (let* ((result (string-join (reverse lines) "\n")) + (full-text (string-append "Hex Dump (" (number->string len) " bytes):\n\n" + result "\n")) + (buf (or (buffer-by-name "*Hex*") + (buffer-create! "*Hex*" ed #f)))) + (buffer-attach! ed buf) + (edit-window-buffer-set! (current-window fr) buf) + (editor-set-text ed full-text) + (editor-set-save-point ed) + (editor-goto-pos ed 0) + (echo-message! echo "*Hex*")))) + + ;;;========================================================================= + ;;; Count matches, delete duplicate lines + ;;;========================================================================= + + (define (cmd-count-matches app) + (let* ((echo (app-state-echo app)) + (fr (app-state-frame app)) + (row (- (frame-height fr) 1)) + (width (frame-width fr)) + (pattern (echo-read-string echo "Count matches for: " row width))) + (if (not pattern) + (echo-message! echo "Cancelled") + (let* ((ed (current-editor app)) + (text (editor-get-text ed)) + (plen (string-length pattern)) + (count + (if (= plen 0) 0 + (let loop ((pos 0) (n 0)) + (let ((idx (string-contains text pattern pos))) + (if idx + (loop (+ idx plen) (+ n 1)) + n)))))) + (echo-message! echo + (string-append (number->string count) " occurrence" + (if (= count 1) "" "s") + " of \"" pattern "\"")))))) + + (define (cmd-delete-duplicate-lines app) + (let* ((ed (current-editor app)) + (echo (app-state-echo app)) + (buf (current-buffer-from-app app)) + (mark (buffer-mark buf)) + (text (editor-get-text ed))) + (let-values (((start end) + (if mark + (let ((pos (editor-get-current-pos ed))) + (values (min mark pos) (max mark pos))) + (values 0 (string-length text))))) + (let* ((region (substring text start end)) + (lines (string-split region #\newline)) + ;; Remove duplicates while preserving order + (seen (make-hash-table)) + (unique + (filter (lambda (line) + (if (hash-get seen line) + #f + (begin (hash-put! seen line #t) #t))) + lines)) + (removed (- (length lines) (length unique))) + (result (string-join unique "\n"))) + (with-undo-action ed + (editor-delete-range ed start (- end start)) + (editor-insert-text ed start result)) + (when mark (buffer-mark-set! buf #f)) + (echo-message! echo + (string-append "Removed " (number->string removed) " duplicate line" + (if (= removed 1) "" "s"))))))) + + ;;;========================================================================= + ;;; Diff buffer with file + ;;;========================================================================= + + (define (cmd-diff-buffer-with-file app) + (let* ((ed (current-editor app)) + (echo (app-state-echo app)) + (fr (app-state-frame app)) + (buf (current-buffer-from-app app)) + (path (buffer-file-path buf))) + (if (not path) + (echo-error! echo "Buffer has no associated file") + (if (not (file-exists? path)) + (echo-error! echo (string-append "File not found: " path)) + (let* ((file-text (read-file-as-string path)) + (buf-text (editor-get-text ed)) + (pid (number->string (get-process-id))) + (tmp1 (string-append "/tmp/jemacs-diff-file-" pid)) + (tmp2 (string-append "/tmp/jemacs-diff-buf-" pid))) + (write-string-to-file file-text tmp1) + (write-string-to-file buf-text tmp2) + (let* ((proc (open-process (list "/usr/bin/diff" "-u" tmp1 tmp2))) + (output (get-string-all (process-port-rec-stdout-port proc)))) + ;; Clean up temp files + (guard (e [#t (void)]) (delete-file tmp1)) + (guard (e [#t (void)]) (delete-file tmp2)) + (if (and (string? output) (> (string-length output) 0)) + ;; Show diff in *Diff* buffer + (let ((diff-buf (or (buffer-by-name "*Diff*") + (buffer-create! "*Diff*" ed #f)))) + (buffer-attach! ed diff-buf) + (edit-window-buffer-set! (current-window fr) diff-buf) + (editor-set-text ed output) + (editor-set-save-point ed) + (editor-goto-pos ed 0) + (echo-message! echo "*Diff*")) + (echo-message! echo "No differences")))))))) + + ;;;========================================================================= + ;;; Checksum: SHA256 + ;;;========================================================================= + + (define (cmd-checksum app) + (let* ((ed (current-editor app)) + (echo (app-state-echo app)) + (buf (current-buffer-from-app app)) + (mark (buffer-mark buf)) + (text (editor-get-text ed))) + (let-values (((start end) + (if mark + (let ((pos (editor-get-current-pos ed))) + (values (min mark pos) (max mark pos))) + (values 0 (string-length text))))) + (let* ((region (substring text start end)) + (hash-bytes (sha256-stub (string->utf8 region))) + (hex-str (hex-encode hash-bytes))) + (when mark (buffer-mark-set! buf #f)) + (echo-message! echo (string-append "SHA256: " hex-str)))))) + + ;;;========================================================================= + ;;; Async shell command + ;;;========================================================================= + + (define (cmd-async-shell-command app) + (let* ((echo (app-state-echo app)) + (fr (app-state-frame app)) + (row (- (frame-height fr) 1)) + (width (frame-width fr)) + (cmd (echo-read-string echo "Async shell command: " row width))) + (if (not cmd) + (echo-message! echo "Cancelled") + (let* ((ed (current-editor app)) + (proc (open-process (list "/bin/sh" "-c" cmd))) + (output (get-string-all (process-port-rec-stdout-port proc)))) + (if (and (string? output) (> (string-length output) 0)) + (let ((out-buf (or (buffer-by-name "*Async Shell*") + (buffer-create! "*Async Shell*" ed #f)))) + (buffer-attach! ed out-buf) + (edit-window-buffer-set! (current-window fr) out-buf) + (editor-set-text ed + (string-append "$ " cmd "\n\n" output "\n")) + (editor-set-save-point ed) + (editor-goto-pos ed 0) + (echo-message! echo "*Async Shell*")) + (echo-message! echo "Command finished")))))) + + ;;;========================================================================= + ;;; Toggle truncate lines + ;;;========================================================================= + + (define (cmd-toggle-truncate-lines app) + (cmd-toggle-word-wrap app)) + + ;;;========================================================================= + ;;; Grep in buffer + ;;;========================================================================= + + (define (cmd-grep-buffer app) + (let* ((echo (app-state-echo app)) + (fr (app-state-frame app)) + (row (- (frame-height fr) 1)) + (width (frame-width fr)) + (pattern (echo-read-string echo "Grep buffer: " row width))) + (if (not pattern) + (echo-message! echo "Cancelled") + (let* ((ed (current-editor app)) + (text (editor-get-text ed)) + (buf-name (buffer-name (current-buffer-from-app app))) + (lines (string-split text #\newline)) + (matches '()) + (line-num 0)) + ;; Collect matching lines with line numbers + (for-each + (lambda (line) + (set! line-num (+ line-num 1)) + (when (string-contains line pattern) + (set! matches + (cons (string-append + (number->string line-num) ": " line) + matches)))) + lines) + (if (null? matches) + (echo-message! echo (string-append "No matches for '" pattern "'")) + (let* ((result (string-append "Grep: " pattern " in " buf-name "\n\n" + (string-join (reverse matches) "\n") "\n")) + (grep-buf (or (buffer-by-name "*Grep*") + (buffer-create! "*Grep*" ed #f)))) + (buffer-attach! ed grep-buf) + (edit-window-buffer-set! (current-window fr) grep-buf) + (editor-set-text ed result) + (editor-set-save-point ed) + (editor-goto-pos ed 0) + (echo-message! echo + (string-append (number->string (length matches)) " match" + (if (= (length matches) 1) "" "es"))))))))) + + ;;;========================================================================= + ;;; Misc: insert-date, insert-char + ;;;========================================================================= + + (define (cmd-insert-date app) + (let* ((ed (current-editor app)) + (pos (editor-get-current-pos ed)) + (proc (open-process (list "/bin/date"))) + (output (get-line (process-port-rec-stdout-port proc)))) + (when (and (string? output) (> (string-length output) 0)) + (editor-insert-text ed pos output)))) + + (define (cmd-insert-char app) + (let* ((echo (app-state-echo app)) + (fr (app-state-frame app)) + (row (- (frame-height fr) 1)) + (width (frame-width fr)) + (input (echo-read-string echo "Insert char (hex code): " row width))) + (if (not input) + (echo-message! echo "Cancelled") + (let ((code (string->number input 16))) + (if (not code) + (echo-error! echo "Invalid hex code") + (let* ((ed (current-editor app)) + (pos (editor-get-current-pos ed)) + (ch (string (integer->char code)))) + (editor-insert-text ed pos ch) + (echo-message! echo + (string-append "Inserted U+" input)))))))) + + ;;;========================================================================= + ;;; Eval buffer / eval region + ;;;========================================================================= + + (define (cmd-eval-buffer app) + (let* ((ed (current-editor app)) + (echo (app-state-echo app)) + (buf (current-buffer-from-app app)) + (text (editor-get-text ed)) + (name (buffer-name buf))) + (let-values (((count err) (load-user-string! text name))) + (if err + (echo-error! echo (string-append "Error: " err " (see *Errors*)")) + (echo-message! echo + (string-append "Evaluated " (number->string count) + " forms in " name + (if (has-captured-output?) " (see *Output*/*Errors*)" ""))))))) + + (define (cmd-eval-region app) + (let* ((ed (current-editor app)) + (echo (app-state-echo app)) + (buf (current-buffer-from-app app)) + (mark (buffer-mark buf))) + (if (not mark) + (echo-error! echo "No region (set mark first)") + (let* ((pos (editor-get-current-pos ed)) + (start (min mark pos)) + (end (max mark pos)) + (region (substring (editor-get-text ed) start end))) + (let-values (((result error?) (eval-expression-string region))) + (buffer-mark-set! buf #f) + (if error? + (echo-error! echo (string-append "Error: " result)) + (echo-message! echo (string-append "=> " result)))))))) + + ;;;========================================================================= + ;;; Clone buffer, scratch buffer + ;;;========================================================================= + + (define (cmd-clone-buffer app) + (let* ((ed (current-editor app)) + (echo (app-state-echo app)) + (fr (app-state-frame app)) + (buf (current-buffer-from-app app)) + (text (editor-get-text ed)) + (new-name (string-append (buffer-name buf) "<clone>")))