Port Tier 5: editor-extra modules compile and all 9 smoke tests pass
ober
6881869f5357b2af7967f46e1b843adab4af9df4
--- a/Makefile +++ b/Makefile @@ -3,11 +3,11 @@ LIBDIRS = --libdirs lib:$(HOME)/mine/jerboa/lib:$(HOME)/mine/chez-pcre2:$(HOME)/ export LD_LIBRARY_PATH := $(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla:$(LD_LIBRARY_PATH) export CHEZ_SCINTILLA_LIB := $(HOME)/mine/chez-scintilla -.PHONY: all test-tier0 test-tier2 test-tier3 test-tier4 test clean +.PHONY: all test-tier0 test-tier2 test-tier3 test-tier4 test-tier5 test clean all: test -test: test-tier0 test-tier2 test-tier3 test-tier4 +test: test-tier0 test-tier2 test-tier3 test-tier4 test-tier5 test-tier0: $(SCHEME) $(LIBDIRS) --script tests/test-tier0.ss @@ -21,5 +21,8 @@ test-tier3: test-tier4: $(SCHEME) $(LIBDIRS) --program tests/test-tier4.ss +test-tier5: + $(SCHEME) $(LIBDIRS) --program tests/test-tier5.ss + clean: find lib -name '*.so' -delete 2>/dev/null; true --- a/lib/jerboa-emacs/editor-extra-final.sls +++ b/lib/jerboa-emacs/editor-extra-final.sls @@ -38,7 +38,6 @@ cmd-enlarge-window-horizontally cmd-shrink-window-horizontally ;; Regex search and replace - *last-regexp-search* cmd-search-forward-regexp cmd-query-replace-regexp-interactive regexp-query-replace-loop! @@ -49,14 +48,11 @@ apply-editorconfig! cmd-editorconfig-apply ;; Format buffer - *formatters* detect-language-from-extension cmd-format-buffer ;; Git blame cmd-git-blame-line ;; Command history - *command-history* - *command-history-file* command-history-load! command-history-save! command-history-add! @@ -68,8 +64,6 @@ find-url-at-point cmd-open-url-at-point ;; MRU buffer switching - *buffer-access-times* - *buffer-access-counter* record-buffer-access! cmd-switch-buffer-mru ;; Shell command on region @@ -85,13 +79,10 @@ ;; Sudo save cmd-sudo-save-buffer ;; Regex builder - *regex-builder-pattern* cmd-regex-builder ;; Web search cmd-eww-search-web ;; Edit position tracking - *last-edit-positions* - *max-edit-positions* record-edit-position! cmd-goto-last-edit ;; Eval region and replace @@ -108,17 +99,9 @@ ;; Prepend to buffer cmd-prepend-to-buffer ;; Persistent scratch - *persistent-scratch-file* cmd-save-persistent-scratch cmd-load-persistent-scratch ;; Batch 33 toggles - *subword-mode* - *auto-composition-mode* - *bidi-display-reordering* - *fill-column-indicator* - *pixel-scroll-mode* - *auto-highlight-symbol-mode* - *lorem-ipsum-text* insert-char-by-code-string cmd-insert-char-by-code cmd-toggle-subword-mode @@ -132,16 +115,6 @@ cmd-copy-rectangle-to-clipboard cmd-insert-file-contents-at-point ;; Batch 39 toggles - *read-only-directories* - *auto-revert-verbose* - *uniquify-buffer-names* - *global-so-long-mode* - *minibuffer-depth-indicate* - *context-menu-mode* - *tooltip-mode* - *file-name-shadow-mode* - *minibuffer-electric-default* - *history-delete-duplicates* cmd-toggle-read-only-directories cmd-toggle-auto-revert-verbose cmd-toggle-uniquify-buffer-names @@ -153,14 +126,6 @@ cmd-toggle-minibuffer-electric-default cmd-toggle-history-delete-duplicates ;; Batch 45 toggles - *modus-themes* - *ef-themes* - *nano-theme* - *ligature-mode* - *pixel-scroll-precision* - *tab-line-mode* - *scroll-bar-mode* - *tool-bar-mode* cmd-toggle-modus-themes cmd-toggle-ef-themes cmd-toggle-nano-theme @@ -171,13 +136,6 @@ cmd-toggle-scroll-bar-mode cmd-toggle-tool-bar-mode ;; Batch 51 toggles - *global-auto-revert-non-file* - *global-tree-sitter* - *global-copilot* - *global-lsp-mode* - *global-format-on-save* - *global-yas* - *global-smartparens* cmd-toggle-global-auto-revert-non-file cmd-toggle-global-tree-sitter cmd-toggle-global-copilot @@ -186,13 +144,6 @@ cmd-toggle-global-yas cmd-toggle-global-smartparens ;; Batch 59 toggles - *global-helpful* - *global-elisp-demos* - *global-suggest* - *global-buttercup* - *global-ert-runner* - *global-undercover* - *global-benchmark-init* cmd-toggle-global-helpful cmd-toggle-global-elisp-demos cmd-toggle-global-suggest @@ -201,13 +152,6 @@ cmd-toggle-global-undercover cmd-toggle-global-benchmark-init ;; Batch 68 toggles - *global-clojure-mode* - *global-cider* - *global-haskell-mode* - *global-lua-mode* - *global-ruby-mode* - *global-php-mode* - *global-swift-mode* cmd-toggle-global-clojure-mode cmd-toggle-global-cider cmd-toggle-global-haskell-mode @@ -216,14 +160,10 @@ cmd-toggle-global-php-mode cmd-toggle-global-swift-mode ;; Scratch buffer new - *tui-scratch-counter* cmd-scratch-buffer-new ;; Swap window cmd-swap-window ;; Parity batch 9 - *tui-workspaces* - *tui-current-ws* - *tui-ws-bufs* cmd-workspace-create cmd-workspace-switch cmd-workspace-delete @@ -231,10 +171,8 @@ cmd-workspace-list cmd-copy-buffer-filename cmd-revert-buffer-confirm - *tui-undo-history* cmd-undo-history cmd-undo-history-restore - *tui-xref-stack* cmd-xref-back) (import @@ -243,13 +181,13 @@ (jerboa core) (jerboa runtime) (only (jerboa prelude) path-expand path-directory path-strip-directory - path-extension take) + path-extension take sort sort!) (std sugar) (only (std srfi srfi-13) string-join string-prefix? string-suffix? string-index string-trim string-trim-both) (only (std srfi srfi-19) - current-date date->string make-time time-utc time-utc->date) + current-date date->string make-time time-utc time-utc->date current-time time->seconds) (only (std misc string) string-split) (std misc process) (chez-scintilla constants) --- a/lib/jerboa-emacs/editor-extra-modes.sls +++ b/lib/jerboa-emacs/editor-extra-modes.sls @@ -210,9 +210,10 @@ (jerboa runtime) (only (jerboa prelude) path-expand path-directory path-strip-directory path-extension) (std sugar) - (only (std srfi srfi-13) string-join string-prefix? string-contains string-trim string-suffix?) + (only (std srfi srfi-13) string-join string-prefix? string-contains string-trim string-suffix? string-index) (only (std misc string) string-split) (std misc process) + (only (std misc thread) thread-sleep! thread-start! make-thread) (only (jerboa-emacs pregexp-compat) pregexp pregexp-match) (chez-scintilla constants) (chez-scintilla scintilla) @@ -222,14 +223,14 @@ (jerboa-emacs window) (jerboa-emacs echo) (jerboa-emacs editor-core) - (except (jerboa-emacs editor-text) shell-quote) + (except (jerboa-emacs editor-text) shell-quote cmd-cycle-spacing) (jerboa-emacs editor-ui) - (jerboa-emacs editor-advanced) - (jerboa-emacs editor-cmds-a) - (except (jerboa-emacs editor-cmds-b) open-output-buffer) - (jerboa-emacs editor-cmds-c) - (only (jerboa-emacs editor-extra-helpers) cmd-flyspell-mode project-current) - (except (jerboa-emacs editor-extra-vcs) cmd-desktop-read) + (except (jerboa-emacs editor-advanced) cmd-count-lines-region cmd-scratch-buffer) + (except (jerboa-emacs editor-cmds-a) cmd-toggle-line-move-visual cmd-goto-last-change) + (except (jerboa-emacs editor-cmds-b) open-output-buffer cmd-recentf-cleanup) + (except (jerboa-emacs editor-cmds-c) cmd-completion-at-point run-git-command) + (except (jerboa-emacs editor-extra-helpers) current-editor app-read-string current-buffer-from-app editor-replace-selection) + (except (jerboa-emacs editor-extra-vcs) cmd-desktop-read cmd-desktop-save) (jerboa-emacs editor-extra-media) (jerboa-emacs editor-extra-media2) (only (jerboa-emacs persist) which-key-mode which-key-mode-set!)) @@ -264,11 +265,11 @@ (let* ((start (min match (- pos 1))) (end (+ (max match (- pos 1)) 1)) (text (substring (editor-get-text ed) start end)) - (result (with-exception-catcher - (lambda (e) (with-output-to-string (lambda () (display-condition e)))) + (result (with-catch + (lambda (e) (call-with-string-output-port (lambda (p) (display-condition e p)))) (lambda () (let ((val (eval (with-input-from-string text read)))) - (with-output-to-string (lambda () (write val)))))))) + (call-with-string-output-port (lambda (p) (write val p)))))))) (echo-message! (app-state-echo app) result)) (echo-message! (app-state-echo app) "No sexp before point")))))) @@ -291,11 +292,11 @@ (match-pos (send-message ed SCI_BRACEMATCH start 0))) (if (>= match-pos 0) (let* ((form-text (substring text start (+ match-pos 1))) - (result (with-exception-catcher - (lambda (e) (with-output-to-string (lambda () (display-condition e)))) + (result (with-catch + (lambda (e) (call-with-string-output-port (lambda (p) (display-condition e p)))) (lambda () (let ((val (eval (with-input-from-string form-text read)))) - (with-output-to-string (lambda () (write val)))))))) + (call-with-string-output-port (lambda (p) (write val p)))))))) (echo-message! (app-state-echo app) result)) (echo-message! (app-state-echo app) "No top-level form found")))) @@ -310,11 +311,11 @@ (let* ((start (min match (- pos 1))) (end (+ (max match (- pos 1)) 1)) (text (substring (editor-get-text ed) start end)) - (result (with-exception-catcher - (lambda (e) (with-output-to-string (lambda () (display-condition e)))) + (result (with-catch + (lambda (e) (call-with-string-output-port (lambda (p) (display-condition e p)))) (lambda () (let ((val (eval (with-input-from-string text read)))) - (with-output-to-string (lambda () (write val)))))))) + (call-with-string-output-port (lambda (p) (write val p)))))))) (editor-insert-text ed pos (string-append "\n;; => " result))) (echo-message! (app-state-echo app) "No sexp before point")))) @@ -349,11 +350,11 @@ (if (= start end) (echo-message! (app-state-echo app) "No region selected") (let* ((region (substring (editor-get-text ed) start end)) - (result (with-exception-catcher - (lambda (e) (with-output-to-string (lambda () (display-condition e)))) + (result (with-catch + (lambda (e) (call-with-string-output-port (lambda (p) (display-condition e p)))) (lambda () (let ((val (eval (with-input-from-string region read)))) - (with-output-to-string (lambda () (write val)))))))) + (call-with-string-output-port (lambda (p) (write val p)))))))) (echo-message! (app-state-echo app) result))))) (define (cmd-scheme-send-buffer app) @@ -362,11 +363,11 @@ (win (current-window fr)) (ed (edit-window-editor win)) (text (editor-get-text ed)) - (result (with-exception-catcher - (lambda (e) (with-output-to-string (lambda () (display-condition e)))) + (result (with-catch + (lambda (e) (call-with-string-output-port (lambda (p) (display-condition e p)))) (lambda () (let ((val (eval (with-input-from-string text read)))) - (with-output-to-string (lambda () (write val)))))))) + (call-with-string-output-port (lambda (p) (write val p)))))))) (echo-message! (app-state-echo app) result))) ;; Regex builder @@ -554,7 +555,7 @@ (words (filter (lambda (w) (> (string-length w) 0)) (string-split text #\space))) (misspelled 0)) - (with-exception-catcher + (with-catch (lambda (e) (echo-error! (app-state-echo app) "aspell not available")) (lambda () (for-each @@ -585,18 +586,16 @@ (word (substring text word-start word-end))) (if (string=? word "") (echo-message! (app-state-echo app) "No word at point") - (with-exception-catcher + (with-catch (lambda (e) (echo-error! (app-state-echo app) "aspell not available")) (lambda () - (let* ((proc (open-process - (list path: "aspell" - arguments: '("pipe") - stdin-redirection: #t stdout-redirection: #t stderr-redirection: #f))) - (_ (begin (display (string-append word "\n") proc) (force-output proc))) - (banner (get-line proc)) - (result (get-line proc))) - (close-output-port proc) - (process-status proc) + (let* ((pp (open-process (list "aspell" "pipe"))) + (in-port (process-port-rec-stdin-port pp)) + (out-port (process-port-rec-stdout-port pp)) + (_ (begin (display (string-append word "\n") in-port) (flush-output-port in-port))) + (banner (get-line out-port)) + (result (get-line out-port))) + (close-port in-port) (cond ((or (not result) (string=? result "") (char=? (string-ref result 0) #\*)) (echo-message! (app-state-echo app) (string-append "'" word "' is correct"))) @@ -624,30 +623,19 @@ ;; Docker (define (cmd-docker app) "Docker management interface — shows containers and images." - (with-exception-catcher + (with-catch (lambda (e) (echo-error! (app-state-echo app) "Docker not available")) (lambda () - (let* ((proc (open-process - (list path: "docker" - arguments: '("info" "--format" "Server Version: {{.ServerVersion}}\nContainers: {{.Containers}}\nImages: {{.Images}}") - stdin-redirection: #f stdout-redirection: #t stderr-redirection: #t))) - (out (get-string-all proc))) - (process-status proc) + (let* ((out (run-process (list "docker" "info" "--format" "Server Version: {{.ServerVersion}}\nContainers: {{.Containers}}\nImages: {{.Images}}")))) (open-output-buffer app "*Docker*" (or out "Docker info unavailable")))))) (define (cmd-docker-containers app) "List docker containers." - (let ((result (with-exception-catcher + (let ((result (with-catch (lambda (e) "Docker not available") (lambda () - (let ((p (open-process - (list path: "docker" - arguments: '("ps" "--format" "{{.Names}}\t{{.Status}}\t{{.Image}}") - stdin-redirection: #f stdout-redirection: #t - stderr-redirection: #t)))) - (let ((out (get-string-all p))) - (process-status p) - (or out "(no containers)"))))))) + (let* ((out (run-process (list "docker" "ps" "--format" "{{.Names}}\t{{.Status}}\t{{.Image}}")))) + (or out "(no containers)")))))) (let* ((fr (app-state-frame app)) (win (current-window fr)) (ed (edit-window-editor win)) @@ -659,15 +647,10 @@ (define (cmd-docker-images app) "List docker images." - (with-exception-catcher + (with-catch (lambda (e) (echo-error! (app-state-echo app) "Docker not available")) (lambda () - (let* ((proc (open-process - (list path: "docker" - arguments: '("images" "--format" "{{.Repository}}\t{{.Tag}}\t{{.Size}}") - stdin-redirection: #f stdout-redirection: #t stderr-redirection: #t))) - (out (get-string-all proc))) - (process-status proc) + (let* ((out (run-process (list "docker" "images" "--format" "{{.Repository}}\t{{.Tag}}\t{{.Size}}")))) (open-output-buffer app "*Docker Images*" (string-append "Docker Images\n\nRepository\tTag\tSize\n" (or out "(no images)") "\n")))))) @@ -699,15 +682,10 @@ (url (if (> (length parts) 1) (cadr parts) ""))) (if (string=? url "") (echo-error! (app-state-echo app) "No URL on current line") - (with-exception-catcher + (with-catch (lambda (e) (echo-error! (app-state-echo app) "curl failed")) (lambda () - (let* ((proc (open-process - (list path: "curl" - arguments: (list "-s" "-X" method url) - stdin-redirection: #f stdout-redirection: #t stderr-redirection: #t))) - (out (get-string-all proc))) - (process-status proc) + (let* ((out (run-process (list "curl" "-s" "-X" method url)))) (open-output-buffer app "*HTTP Response*" (string-append method " " url "\n\n" (or out "(no response)") "\n"))))))))) @@ -814,7 +792,7 @@ "Collect all words in text that start with prefix, excluding the one at prefix-start." (let ((len (string-length text)) (plen (string-length prefix)) - (candidates [])) + (candidates '())) (let loop ((i 0)) (when (< i len) (let* ((wstart @@ -928,26 +906,25 @@ (define (gdb-send! cmd app) "Send command to GDB and display response." (let ((proc *gdb-process*)) - (when (port? proc) - (display (string-append cmd "\n") proc) - (force-output proc) - (thread-sleep! 0.1) - (let ((out (with-exception-catcher (lambda (e) #f) (lambda () (get-line proc))))) - (when (string? out) - (echo-message! (app-state-echo app) out)))))) + (when (process-port? proc) + (let ((in-port (process-port-rec-stdin-port proc)) + (out-port (process-port-rec-stdout-port proc))) + (display (string-append cmd "\n") in-port) + (flush-output-port in-port) + (thread-sleep! 0.1) + (let ((out (with-catch (lambda (e) #f) (lambda () (get-line out-port))))) + (when (string? out) + (echo-message! (app-state-echo app) out))))))) (define (cmd-gdb app) "Start GDB debugger — spawns gdb subprocess with MI interface." (let ((program (app-read-string app "Program to debug: "))) (if (or (not program) (string=? program "")) (echo-error! (app-state-echo app) "No program specified") - (with-exception-catcher + (with-catch (lambda (e) (echo-error! (app-state-echo app) "GDB not available")) (lambda () - (let* ((proc (open-process - (list path: "gdb" - arguments: (list "-q" "--interpreter=mi2" program) - stdin-redirection: #t stdout-redirection: #t stderr-redirection: #t))) + (let* ((proc (open-process (list "gdb" "-q" "--interpreter=mi2" program))) (fr (app-state-frame app)) (win (current-window fr)) (ed (edit-window-editor win)) @@ -1286,18 +1263,10 @@ (echo (app-state-echo app))) (if (not file-path) (echo-message! echo "Buffer has no file") - (with-exception-catcher + (with-catch (lambda (e) (echo-message! echo "Not in a git repository")) (lambda () - (let* ((proc (open-process - (list path: "git" - arguments: (list "diff" "--no-color" "-U0" "--" file-path) - stdin-redirection: #f - stdout-redirection: #t - stderr-redirection: #f - directory: (path-directory file-path)))) - (output (get-string-all proc))) - (process-status proc) + (let* ((output (run-process (list "git" "diff" "--no-color" "-U0" "--" file-path) 'directory: (path-directory file-path)))) (let ((hunks (git-gutter-parse-diff (or output "")))) (hash-put! *git-gutter-hunks* buf-name hunks) (hash-put! *git-gutter-hunk-idx* buf-name 0) @@ -1441,21 +1410,15 @@ (let ((hunks (or (hash-get *git-gutter-hunks* buf-name) '()))) (if (null? hunks) (echo-message! echo "No hunks to revert") - (with-exception-catcher + (with-catch (lambda (e) (echo-error! echo "Failed to revert")) (lambda () ;; For simplicity, revert entire file and reload - (let* ((proc (open-process - (list path: "git" - arguments: (list "checkout" "--" file-path) - stdin-redirection: #f - stdout-redirection: #t - stderr-redirection: #t - directory: (path-directory file-path))))) - (process-status proc) + (begin + (run-process (list "git" "checkout" "--" file-path) 'directory: (path-directory file-path)) ;; Reload file (let ((ed (edit-window-editor win)) - (text (with-exception-catcher + (text (with-catch (lambda (e) #f) (lambda () (call-with-input-file file-path @@ -1475,17 +1438,11 @@ (echo (app-state-echo app))) (if (not file-path) (echo-error! echo "Buffer has no file") - (with-exception-catcher + (with-catch (lambda (e) (echo-error! echo "Failed to stage")) (lambda () - (let* ((proc (open-process - (list path: "git" - arguments: (list "add" "--" file-path) - stdin-redirection: #f - stdout-redirection: #t - stderr-redirection: #t - directory: (path-directory file-path))))) - (process-status proc) + (begin + (run-process (list "git" "add" "--" file-path) 'directory: (path-directory file-path)) ;; Refresh hunks (git-gutter-refresh! app) (echo-message! echo (string-append "Staged: " (path-strip-directory file-path))))))))) @@ -1705,7 +1662,7 @@ (if (or (eq? type 'none) (string=? target "")) (echo-message! echo "No target at point") (let* ((actions (or (assq type *embark-target-actions*) #f)) - (action-list (if actions (cdr actions) []))) + (action-list (if actions (cdr actions) '()))) (if (null? action-list) (echo-message! echo (string-append "No actions for " (symbol->string type))) ;; Show actions and prompt for selection @@ -1781,10 +1738,10 @@ ;; Which-key extras (define (cmd-which-key-mode app) "Toggle which-key mode — shows available keybindings after prefix delay." - (set! *which-key-mode* (not *which-key-mode*)) + (which-key-mode-set! (not (which-key-mode))) (toggle-mode! 'which-key) ;; keep mode registry in sync (echo-message! (app-state-echo app) - (if *which-key-mode* "Which-key mode enabled" "Which-key mode disabled"))) + (if (which-key-mode) "Which-key mode enabled" "Which-key mode disabled"))) ;; Helpful — enhanced help system (define (cmd-helpful-callable app) @@ -1802,7 +1759,7 @@ (when (and name (not (string=? name ""))) (let ((val (hash-get *custom-variables* name))) (if val - (echo-message! (app-state-echo app) (string-append name " = " (with-output-to-string (lambda () (write val))))) + (echo-message! (app-state-echo app) (string-append name " = " (call-with-string-output-port (lambda (p) (write val p))))) (echo-message! (app-state-echo app) (string-append "'" name "' not found"))))))) (define (cmd-helpful-key app) @@ -1871,7 +1828,7 @@ (linenum (cadr parsed)) (new-content (caddr parsed))) (when (file-exists? filename) - (with-exception-catcher + (with-catch (lambda (e) #f) (lambda () (let* ((file-text (call-with-input-file filename @@ -2071,19 +2028,14 @@ (let ((query (app-read-string app "Devdocs search: "))) (when (and query (not (string=? query ""))) (echo-message! (app-state-echo app) (string-append "Fetching devdocs for: " query "...")) - (with-exception-catcher + (with-catch (lambda (e) (echo-message! (app-state-echo app) (string-append "Devdocs: https://devdocs.io/#q=" query))) (lambda () (let* ((url (string-append "https://devdocs.io/api/search?query=" query)) - (proc (open-process - (list path: "curl" - arguments: (list "-s" "-L" "--max-time" "5" - (string-append "https://devdocs.io/#q=" query)) - stdin-redirection: #f stdout-redirection: #t stderr-redirection: #f))) - (out (get-string-all proc))) - (process-status proc) + (out (run-process (list "curl" "-s" "-L" "--max-time" "5" + (string-append "https://devdocs.io/#q=" query))))) (if (and out (> (string-length out) 0)) (let* ((fr (app-state-frame app)) (win (current-window fr)) @@ -2171,21 +2123,16 @@ "Create denote note — creates timestamped note file." (let ((title (app-read-string app "Note title: "))) (when (and title (not (string=? title ""))) - (let* ((timestamp (with-exception-catcher + (let* ((timestamp (with-catch (lambda (e) "20260213") (lambda () - (let* ((proc (open-process - (list path: "date" - arguments: '("+%Y%m%dT%H%M%S") - stdin-redirection: #f stdout-redirection: #t stderr-redirection: #f))) - (out (get-line proc))) - (process-status proc) - (or out "20260213"))))) - (slug (string-map (lambda (c) (if (char-alphabetic? c) (char-downcase c) #\-)) title)) + (let* ((raw (run-process (list "date" "+%Y%m%dT%H%M%S")))) + (or (and raw (car (string-split raw #\newline))) "20260213"))))) + (slug (list->string (map (lambda (c) (if (char-alphabetic? c) (char-downcase c) #\-)) (string->list title)))) (dir (string-append (getenv "HOME") "/notes/")) (fname (string-append dir timestamp "--" slug ".org"))) ;; Ensure directory exists - (with-exception-catcher (lambda (e) #f) (lambda () (create-directory dir))) + (with-catch (lambda (e) #f) (lambda () (mkdir dir))) (let* ((fr (app-state-frame app)) (win (current-window fr)) (ed (edit-window-editor win)) @@ -2216,15 +2163,10 @@ (let ((query (app-read-string app "Find node: "))) (when (and query (not (string=? query ""))) (let ((notes-dir (string-append (getenv "HOME") "/notes/"))) - (with-exception-catcher + (with-catch (lambda (e) (echo-error! (app-state-echo app) "Notes directory not found")) (lambda () - (let* ((proc (open-process - (list path: "grep" - arguments: (list "-rl" query notes-dir) - stdin-redirection: #f stdout-redirection: #t stderr-redirection: #f))) - (out (get-string-all proc))) - (process-status proc) + (let* ((out (run-process (list "grep" "-rl" query notes-dir)))) (if (and out (> (string-length out) 0)) (open-output-buffer app "*Org-roam*" out) (echo-message! (app-state-echo app) "No matching nodes found"))))))))) @@ -2370,16 +2312,10 @@ (dir (if (and buf (buffer-file-path buf)) (path-directory (buffer-file-path buf)) (current-directory)))) - (with-exception-catcher + (with-catch (lambda (e) (echo-error! (app-state-echo app) "Git command failed")) (lambda () - (let* ((proc (open-process - (list path: "git" - arguments: args - directory: dir - stdin-redirection: #f stdout-redirection: #t stderr-redirection: #t))) - (out (get-string-all proc))) - (process-status proc) + (let* ((out (run-process (append (list "git") args) 'directory: dir))) (if buffer-name (open-output-buffer app buffer-name (or out "(no output)\n")) (echo-message! (app-state-echo app) (or out "Done")))))))) @@ -2399,15 +2335,10 @@ (define (tui-git-run-in-dir args dir) "Run git command synchronously in dir, return output string." - (with-exception-catcher + (with-catch (lambda (e) "") (lambda () - (let* ((proc (open-process - (list path: "git" arguments: args directory: dir - stdout-redirection: #t stderr-redirection: #t))) - (out (get-string-all proc))) - (close-port proc) - (or out ""))))) + (or (run-process (append (list "git") args) 'directory: dir) "")))) (define (tui-git-dir app) "Get git directory from current buffer." @@ -2738,9 +2669,9 @@ (region (substring text start end)) (path (app-read-string app "Append to file: "))) (when (and path (not (string=? path ""))) - (call-with-output-file [path: path append: #t] - (lambda (p) (display region p))) + (let ((p (open-output-file path 'append))) + (display region p) + (close-port p)) (echo-message! (app-state-echo app) (string-append "Appended " (number->string (- end start)) " chars to " path))))))) -) ;; end body ) ;; end library --- a/lib/jerboa-emacs/editor-extra-org.sls +++ b/lib/jerboa-emacs/editor-extra-org.sls @@ -118,7 +118,24 @@ cmd-toggle-global-diff-auto-refine cmd-toggle-global-eldoc-box cmd-toggle-global-flyspell-lazy - cmd-toggle-global-so-clean) + cmd-toggle-global-so-clean + ;; Org table stubs + cmd-org-table-align + cmd-org-table-delete-column + cmd-org-table-delete-row + cmd-org-table-export-csv + cmd-org-table-import-csv + cmd-org-table-insert-column + cmd-org-table-insert-row + cmd-org-table-insert-separator + cmd-org-table-move-column-left + cmd-org-table-move-column-right + cmd-org-table-move-row-down + cmd-org-table-move-row-up + cmd-org-table-recalculate + cmd-org-table-sort + cmd-org-table-sum + cmd-org-table-transpose) (import (except (chezscheme) make-hash-table hash-table? iota 1+ 1- sort sort! path-extension) (jerboa core) @@ -1160,7 +1177,7 @@ (12 25 "Christmas Day"))) (define *tui-diary-file* - (path-expand ".jemacs-diary" (or (getenv "HOME") "/tmp"))) + (string-append (or (getenv "HOME") "/tmp") "/.jemacs-diary")) (define (tui-holidays-for-month month) "Return holidays in month as list of (day . name)." @@ -2141,6 +2158,24 @@ ;;; Register org-mode syntax highlighter ;;;========================================================================== + ;;; Org table stubs + (define (cmd-org-table-align app) (echo-message! (app-state-echo app) "org-table-align: not yet implemented")) + (define (cmd-org-table-delete-column app) (echo-message! (app-state-echo app) "org-table-delete-column: not yet implemented")) + (define (cmd-org-table-delete-row app) (echo-message! (app-state-echo app) "org-table-delete-row: not yet implemented")) + (define (cmd-org-table-export-csv app) (echo-message! (app-state-echo app) "org-table-export-csv: not yet implemented")) + (define (cmd-org-table-import-csv app) (echo-message! (app-state-echo app) "org-table-import-csv: not yet implemented")) + (define (cmd-org-table-insert-column app) (echo-message! (app-state-echo app) "org-table-insert-column: not yet implemented")) + (define (cmd-org-table-insert-row app) (echo-message! (app-state-echo app) "org-table-insert-row: not yet implemented")) + (define (cmd-org-table-insert-separator app) (echo-message! (app-state-echo app) "org-table-insert-separator: not yet implemented")) + (define (cmd-org-table-move-column-left app) (echo-message! (app-state-echo app) "org-table-move-column-left: not yet implemented")) + (define (cmd-org-table-move-column-right app) (echo-message! (app-state-echo app) "org-table-move-column-right: not yet implemented")) + (define (cmd-org-table-move-row-down app) (echo-message! (app-state-echo app) "org-table-move-row-down: not yet implemented")) + (define (cmd-org-table-move-row-up app) (echo-message! (app-state-echo app) "org-table-move-row-up: not yet implemented")) + (define (cmd-org-table-recalculate app) (echo-message! (app-state-echo app) "org-table-recalculate: not yet implemented")) + (define (cmd-org-table-sort app) (echo-message! (app-state-echo app) "org-table-sort: not yet implemented")) + (define (cmd-org-table-sum app) (echo-message! (app-state-echo app) "org-table-sum: not yet implemented")) + (define (cmd-org-table-transpose app) (echo-message! (app-state-echo app) "org-table-transpose: not yet implemented")) + (register-custom-highlighter! 'org (lambda (ed) (setup-org-styles! ed) --- a/lib/jerboa-emacs/editor-extra-regs.sls +++ b/lib/jerboa-emacs/editor-extra-regs.sls @@ -81,8 +81,9 @@ (jerboa runtime) (only (jerboa prelude) path-expand path-directory path-strip-directory) (std sugar) - (only (std srfi srfi-13) string-join string-prefix? string-contains string-trim) + (only (std srfi srfi-13) string-join string-prefix? string-contains string-trim string-index string-suffix?) (only (std misc string) string-split) + (only (std misc list) take drop filter-map) (std misc process) (only (jerboa-emacs pregexp-compat) pregexp pregexp-match) (chez-scintilla constants) @@ -97,7 +98,7 @@ org-babel-tangle-to-files org-babel-insert-result org-babel-kill-all-sessions) (only (jerboa-emacs org-capture) - org-capture-menu-string org-capture-template-key + org-capture-templates org-capture-menu-string org-capture-template-key org-capture-template-template org-capture-cursor-position org-capture-start org-capture-finalize org-capture-abort) (only (jerboa-emacs org-parse) @@ -110,10 +111,11 @@ (jerboa-emacs editor-cmds-a) (except (jerboa-emacs editor-cmds-b) open-output-buffer) (jerboa-emacs editor-cmds-c) - (only (jerboa-emacs editor-extra-helpers) cmd-flyspell-mode project-current) + (only (jerboa-emacs editor-extra-helpers) cmd-flyspell-mode project-current open-output-buffer) (only (jerboa-emacs editor-extra-web) eww-display-page eww-fetch-url) - (only (jerboa-emacs terminal) terminal-buffer?)) + (only (jerboa-emacs terminal) terminal-buffer?) + (only (jerboa-emacs editor-extra-tools2) cmd-toggle-header-line)) (define (register-parity-commands!) ;;; From editor-core.ss @@ -891,12 +893,9 @@ (dir (if path (path-directory path) "."))) (with-catch (lambda (e) (echo-message! (app-state-echo app) - (string-append "Error: " (with-output-to-string (lambda () (display-condition e)))))) + (string-append "Error: " (call-with-string-output-port (lambda (p) (display-condition e p)))))) (lambda () - (let* ((proc (open-process (list path: "ls" arguments: ["-la" dir] - stdin-redirection: #f stdout-redirection: #t stderr-redirection: #t))) - (output (get-string-all proc))) - (close-port proc) + (let ((output (run-process (list "ls" "-la" dir)))) (open-output-buffer app (string-append "*Dired: " dir "*") (or output ""))))))) (define (cmd-dired-up-directory app) @@ -911,10 +910,7 @@ (with-catch (lambda (e) (echo-message! (app-state-echo app) "Cannot go up")) (lambda () - (let* ((proc (open-process (list path: "ls" arguments: ["-la" dir] - stdin-redirection: #f stdout-redirection: #t stderr-redirection: #t))) - (output (get-string-all proc))) - (close-port proc) + (let ((output (run-process (list "ls" "-la" dir)))) (open-output-buffer app (string-append "*Dired: " dir "*") (or output ""))))))) (define (cmd-dired-do-shell-command app) @@ -924,10 +920,7 @@ (with-catch (lambda (e) (echo-message! (app-state-echo app) "Shell command error")) (lambda () - (let* ((proc (open-process (list path: "/bin/sh" arguments: ["-c" cmd] - stdin-redirection: #f stdout-redirection: #t stderr-redirection: #t))) - (output (get-string-all proc))) - (process-status proc) (close-port proc) + (let ((output (run-process (list "/bin/sh" "-c" cmd)))) (open-output-buffer app "*Shell Command*" (or output "")))))))) ;;; --- Help/Apropos --- @@ -963,7 +956,7 @@ (cmd-newline app) (let ((ed2 (current-editor app))) (editor-insert-text ed2 (editor-get-current-pos ed2) prefix))) - (cmd-newline app))) + (cmd-newline app)))) ;;; --- Search --- @@ -991,10 +984,11 @@ (let* ((buf-info (current-buffer-from-app app)) (source-file (or (buffer-name buf-info) "")) (source-path (or (buffer-file-path buf-info) "")) + (templates (org-capture-templates)) (tmpl-str (org-capture-template-template (or (find (lambda (t) (string=? (org-capture-template-key t) key)) - *org-capture-templates*) - (car *org-capture-templates*)))) + templates) + (car templates)))) (cursor-pos (org-capture-cursor-position tmpl-str)) (expanded (org-capture-start key source-file source-path))) (if (not expanded) @@ -1002,7 +996,7 @@ (let* ((ed (current-editor app)) (buf (buffer-create! "*Org Capture*" ed))) (buffer-attach! ed buf) - (set! (edit-window-buffer (current-window fr)) buf) + (edit-window-buffer-set! (current-window fr) buf) (editor-insert-text ed 0 expanded) (when cursor-pos (editor-goto-pos ed (min cursor-pos (string-length expanded)))) @@ -1117,10 +1111,8 @@ (with-catch (lambda (e) (echo-message! (app-state-echo app) "Timestamp error")) (lambda () - (let* ((proc (open-process (list path: "date" arguments: '("+<%Y-%m-%d %a>") - stdin-redirection: #f stdout-redirection: #t stderr-redirection: #t))) - (ts (get-line proc))) - (process-status proc) (close-port proc) + (let* ((raw (run-process (list "date" "+<%Y-%m-%d %a>"))) + (ts (and (string? raw) (car (string-split raw #\newline))))) (when (string? ts) (let ((ed (current-editor app))) (editor-insert-text ed (editor-get-current-pos ed) ts))))))) @@ -1186,7 +1178,7 @@ (echo-message! echo "Not on an org heading") (let* ((child-level (+ parent-level 1)) (entries - (let loop ((i (+ cur-line-idx 1)) (current-entry #f) (entries [])) + (let loop ((i (+ cur-line-idx 1)) (current-entry #f) (entries '())) (if (>= i (length lines)) (if current-entry (append entries (list (reverse current-entry))) entries) (let* ((line (list-ref lines i)) @@ -1213,8 +1205,7 @@ entries)))))))) (if (< (length entries) 2) (echo-message! echo "Nothing to sort (need 2+ child headings)") - (let* ((sorted (sort entries - (lambda (a b) (string<? (string-downcase (car a)) (string-downcase (car b)))))) + (let* ((sorted (list-sort (lambda (a b) (string<? (string-downcase (car a)) (string-downcase (car b)))) entries)) (before-lines (take lines (+ cur-line-idx 1))) (after-start (let loop ((i (+ cur-line-idx 1))) (if (>= i (length lines)) i @@ -1230,7 +1221,7 @@ (if (and is-heading (<= hl parent-level)) i (loop (+ i 1))))))) (after-lines (if (< after-start (length lines)) - (list-tail lines after-start) [])) + (list-tail lines after-start) '())) (sorted-text (apply append sorted)) (new-lines (append before-lines sorted-text after-lines)) (new-text (string-join new-lines "\n"))) @@ -1251,7 +1242,7 @@ (let* ((bufs (filter (lambda (b) (let ((fp (buffer-file-path b))) (and fp (string-prefix? root fp)))) - *buffer-list*)) + (buffer-list))) (names (map buffer-name bufs))) (if (null? names) (echo-message! (app-state-echo app) "No project buffers") @@ -1260,7 +1251,7 @@ (let ((target (find (lambda (b) (string=? (buffer-name b) name)) bufs))) (if target (begin (buffer-attach! (current-editor app) target) - (set! (edit-window-buffer win) target)) + (edit-window-buffer-set! win target)) (echo-message! (app-state-echo app) "Buffer not found")))))))))) (define (find-project-root dir) @@ -1286,9 +1277,9 @@ (let* ((bufs (filter (lambda (b) (let ((fp (buffer-file-path b))) (and fp (string-prefix? root fp)))) - *buffer-list*)) + (buffer-list))) (count (length bufs))) - (for-each (lambda (b) (set! *buffer-list* (remq b *buffer-list*))) bufs) + (for-each buffer-list-remove! bufs) (echo-message! (app-state-echo app) (string-append "Killed " (number->string count) " project buffers")))))) ;;; --- Version control --- @@ -1302,26 +1293,21 @@ (lambda (e) (echo-message! (app-state-echo app) "VC error")) (lambda () (let* ((dir (path-directory path)) - (proc (open-process (list path: "git" arguments: ["status" "--porcelain" "--" path] - directory: dir stdin-redirection: #f stdout-redirection: #t stderr-redirection: #t))) - (status-line (get-line proc))) - (process-status proc) (close-port proc) + (raw (run-process (list "git" "status" "--porcelain" "--" path) 'directory: dir)) + (status-line (and (string? raw) (not (string=? raw "")) + (car (string-split raw #\newline))))) (cond - ((eof-object? status-line) + ((not status-line) (echo-message! (app-state-echo app) "File is clean (no changes)")) ((or (string-prefix? "??" status-line) (string-prefix? "A " status-line)) ;; Untracked or added — stage it - (let ((p2 (open-process (list path: "git" arguments: ["add" "--" path] - directory: dir stdin-redirection: #f stdout-redirection: #t stderr-redirection: #t)))) - (process-status p2) (close-port p2) - (echo-message! (app-state-echo app) (string-append "Staged: " (path-strip-directory path))))) + (run-process/batch (list "git" "add" "--" path) 'directory: dir) + (echo-message! (app-state-echo app) (string-append "Staged: " (path-strip-directory path)))) ((or (string-prefix? " M" status-line) (string-prefix? "M " status-line) (string-prefix? "MM" status-line)) ;; Modified — stage it - (let ((p2 (open-process (list path: "git" arguments: ["add" "--" path] - directory: dir stdin-redirection: #f stdout-redirection: #t stderr-redirection: #t)))) - (process-status p2) (close-port p2) - (echo-message! (app-state-echo app) (string-append "Staged: " (path-strip-directory path))))) + (run-process/batch (list "git" "add" "--" path) 'directory: dir) + (echo-message! (app-state-echo app) (string-append "Staged: " (path-strip-directory path)))) (else (echo-message! (app-state-echo app) (string-append "Status: " (string-trim status-line))))))))))) @@ -1340,7 +1326,7 @@ (let ((nums (pregexp-match "[0-9]+" l))) (cons (if nums (string->number (car nums)) 0) l))) lines)) - (sorted (sort numbered (lambda (a b) (< (car a) (car b))))) + (sorted (list-sort (lambda (a b) (< (car a) (car b))) numbered)) (result (string-join (map cdr sorted) "\n"))) (editor-set-text ed result) (echo-message! (app-state-echo app) @@ -1357,7 +1343,7 @@ (lambda (e) (echo-message! (app-state-echo app) "find error")) (lambda () (let* ((cmd-str (string-append "find " dir " " args)) - (output (run-process ["bash" "-c" cmd-str] coprocess: read-all-as-string))) + (output (run-process (list "bash" "-c" cmd-str)))) (open-output-buffer app "*Find*" (or output "")))))))))) (define (cmd-find-name-dired app) @@ -1370,7 +1356,7 @@ (lambda (e) (echo-message! (app-state-echo app) "find error")) (lambda () (let* ((cmd-str (string-append "find " dir " -name " (string-append "'" pattern "'"))) - (output (run-process ["bash" "-c" cmd-str] coprocess: read-all-as-string))) + (output (run-process (list "bash" "-c" cmd-str)))) (open-output-buffer app "*Find*" (or output "")))))))))) ;;; --- Dired details --- @@ -1382,7 +1368,7 @@ (if *dired-hide-details* "Details hidden" "Details shown")))