diff options
Diffstat (limited to 'elisp')
| -rw-r--r-- | elisp/geiser-base.el | 5 | ||||
| -rw-r--r-- | elisp/geiser-capf.el | 19 | ||||
| -rw-r--r-- | elisp/geiser-connection.el | 35 | ||||
| -rw-r--r-- | elisp/geiser-edit.el | 48 | ||||
| -rw-r--r-- | elisp/geiser-eval.el | 8 | ||||
| -rw-r--r-- | elisp/geiser-impl.el | 8 | ||||
| -rw-r--r-- | elisp/geiser-mode.el | 15 | ||||
| -rw-r--r-- | elisp/geiser-repl.el | 112 | ||||
| -rw-r--r-- | elisp/geiser-syntax.el | 3 | ||||
| -rw-r--r-- | elisp/geiser.el | 4 |
10 files changed, 176 insertions, 81 deletions
diff --git a/elisp/geiser-base.el b/elisp/geiser-base.el index 4194da5..71aa8b4 100644 --- a/elisp/geiser-base.el +++ b/elisp/geiser-base.el @@ -41,9 +41,14 @@ ;;; Utilities: +(require 'ansi-color) + (defsubst geiser--chomp (str) (if (string-match-p ".*\n$" str) (substring str 0 -1) str)) +(defsubst geiser--strip-ansi (s) + (replace-regexp-in-string "" "" (ansi-color-filter-apply s))) + (defun geiser--shorten-str (str len &optional sep) (let ((str-len (length str))) (if (<= str-len len) diff --git a/elisp/geiser-capf.el b/elisp/geiser-capf.el index a3c47a3..e7c1139 100644 --- a/elisp/geiser-capf.el +++ b/elisp/geiser-capf.el @@ -1,6 +1,6 @@ ;;; geiser-capf.el --- Setup for Geiser's CAPFs -*- lexical-binding: t; -*- -;; Copyright (c) 2022 Jose Antonio Ortega Ruiz +;; Copyright (c) 2022, 2025 Jose Antonio Ortega Ruiz ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the Modified BSD License. You should @@ -18,6 +18,7 @@ (require 'geiser-doc) (require 'geiser-completion) (require 'geiser-edit) +(require 'geiser-syntax) (defun geiser-capf--company-docsig (id) (condition-case err @@ -38,13 +39,15 @@ (current-buffer)))))) (defun geiser-capf--company-location (id) - (condition-case _err - (when (and geiser-impl--implementation (not (geiser-autodoc--inhibit))) - (let ((id (make-symbol id))) - (condition-case nil - (geiser-edit-module id 'noselect) - (error (geiser-edit-symbol id 'noselect))))) - (error (message "Location not found for %s" id)))) + (ignore-errors + (when (and geiser-impl--implementation (not (geiser-autodoc--inhibit))) + (let ((id (if (stringp id) (geiser-syntax--form-from-string id) id))) + (if-let* ((mloc (geiser-edit-module-location id)) + (f (geiser-edit--location-file mloc))) + (cons f 1) + (if-let* ((sloc (geiser-edit-symbol-location id)) + (f (geiser-edit--location-file sloc))) + (cons f (or (geiser-edit--location-line sloc) 1)))))))) (defun geiser-capf--thing-at-point (module &optional _predicate) (with-syntax-table scheme-mode-syntax-table diff --git a/elisp/geiser-connection.el b/elisp/geiser-connection.el index af185b4..b59d109 100644 --- a/elisp/geiser-connection.el +++ b/elisp/geiser-connection.el @@ -1,6 +1,6 @@ ;;; geiser-connection.el --- Talking to a scheme process -*- lexical-binding: t; -*- -;; Copyright (C) 2009-2011, 2013, 2021-2022 Jose Antonio Ortega Ruiz +;; Copyright (C) 2009-2011, 2013, 2021-2022, 2025, 2026 Jose Antonio Ortega Ruiz ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the Modified BSD License. You should @@ -39,7 +39,7 @@ ;;; Request datatype: (defun geiser-con--make-request (con str cont &optional sender-buffer) - (list (cons :id (geiser-con--connection-inc-count con)) + (list (cons :id (and (car con) (geiser-con--connection-inc-count con))) (cons :string str) (cons :continuation cont) (cons :buffer (or sender-buffer (current-buffer))) @@ -81,13 +81,13 @@ (progn (geiser-log--error "Unexpected queue input:\n %s" in) (delete-region (point-min) (point-max))) (goto-char (point-max)) - (insert in) + (insert (geiser--strip-ansi in)) (goto-char (point-min)) (when (re-search-forward (tq-queue-head-regexp tq) nil t) (unwind-protect (funcall (tq-queue-head-fn tq) (tq-queue-head-closure tq) - (buffer-substring (point-min) (match-beginning 0))) + (buffer-substring (point-min) (point))) (delete-region (point-min) (point-max)) (tq-queue-pop tq))))))) @@ -110,6 +110,9 @@ (cons :count 0) (cons :completed (make-hash-table :weakness 'value)))) +(defsubst geiser-con--pending-requests-p (c) + (not (tq-queue-empty (geiser-con--connection-tq c)))) + (defsubst geiser-con--connection-process (c) (tq-process (cdr (assq :tq c)))) @@ -139,7 +142,7 @@ (defun geiser-con--connection-update-debugging (c txt) (let* ((dp (geiser-con--connection-debug-prompt c)) - (is-d (and (stringp dp) (string-match dp txt)))) + (is-d (and (stringp dp) (string-match-p dp txt)))) (geiser-con--connection-set-debugging c is-d) is-d)) @@ -260,7 +263,8 @@ (defun geiser-con--send-string (con str cont &optional sbuf) (let ((req (geiser-con--make-request con str cont sbuf))) - (geiser-con--connection-add-request con req) + (when (geiser-con--request-id req) + (geiser-con--connection-add-request con req)) req)) (defvar geiser-connection-timeout 30000 @@ -273,19 +277,24 @@ (interrupt-process proc)))) (defun geiser-con--wait (req timeout) - "Wait up to TIMEOUT msecs for request REQ to finish, returning its result." + "Wait up to TIMEOUT msecs for request REQ to finish." (let* ((con (or (geiser-con--request-connection req) (error "Geiser connection not active"))) (proc (geiser-con--connection-process con)) (id (geiser-con--request-id req)) (timeout (/ (or timeout geiser-connection-timeout) 1000.0)) (step (/ timeout 10))) - (with-timeout (timeout (geiser-con--request-deactivate req)) - (condition-case nil - (while (and (geiser-con--connection-process con) - (not (geiser-con--connection-completed-p con id))) - (accept-process-output proc step)) - (error (geiser-con--request-deactivate req)))))) + (if (null (geiser-con--request-id req)) ;; request sent with paused conn + (when-let* ((cont (geiser-con--request-continuation req))) + (with-current-buffer (or (geiser-con--request-buffer req) + (current-buffer)) + (funcall cont '((result))))) + (with-timeout (timeout (geiser-con--request-deactivate req)) + (condition-case nil + (while (and (geiser-con--connection-process con) + (not (geiser-con--connection-completed-p con id))) + (accept-process-output proc step)) + (error (geiser-con--request-deactivate req))))))) (defun geiser-con--send-string/wait (con str cont &optional timeout sbuf) (when (and (stringp str) (not (string-blank-p str))) diff --git a/elisp/geiser-edit.el b/elisp/geiser-edit.el index 0d47cbe..0c6be2f 100644 --- a/elisp/geiser-edit.el +++ b/elisp/geiser-edit.el @@ -1,6 +1,6 @@ ;;; geiser-edit.el --- Scheme edit locations -*- lexical-binding: t; -*- -;; Copyright (C) 2009, 2010, 2012, 2013, 2019-2024 Jose Antonio Ortega Ruiz +;; Copyright (C) 2009, 2010, 2012, 2013, 2019-2025 Jose Antonio Ortega Ruiz ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the Modified BSD License. You should @@ -155,11 +155,10 @@ or following links in error buffers.") (unless no-error (error "Couldn't find location for '%s'" symbol))))) -(defsubst geiser-edit--try-edit (symbol ret &optional method no-error) - (let ((res (geiser-eval--retort-result ret))) - (if (listp res) - (geiser-edit--try-edit-location symbol res method no-error) - (unless no-error (error "Couldn't find location for '%s'" symbol))))) +(defsubst geiser-edit--try-edit (symbol res &optional method no-error) + (if (listp res) + (geiser-edit--try-edit-location symbol res method no-error) + (unless no-error (error "Couldn't find location for '%s'" symbol)))) ;;; Links @@ -257,26 +256,30 @@ or following links in error buffers.") (defvar geiser-edit--symbol-history nil) +(defun geiser-edit-symbol-location (&optional symbol) + (let* ((symbol (or symbol + (geiser--symbol-at-point) + (error "No symbol at point"))) + (cmd `(:eval (:ge symbol-location ',symbol)))) + (geiser-eval--retort-result (geiser-eval--send/wait cmd)))) + (defun geiser-edit-symbol (symbol &optional method marker) "Asks for a symbol to edit, with completion." (interactive (list (geiser-completion--read-symbol "Edit symbol: " nil geiser-edit--symbol-history))) - (let ((cmd `(:eval (:ge symbol-location ',symbol)))) - (geiser-edit--try-edit symbol (geiser-eval--send/wait cmd) method) - (when marker (xref-push-marker-stack)))) + (geiser-edit--try-edit symbol (geiser-edit-symbol-location symbol) method) + (when marker (xref-push-marker-stack))) (defun geiser-edit-symbol-at-point (&optional arg) "Visit the definition of the symbol at point. With prefix, asks for the symbol to locate." (interactive "P") - (let* ((symbol (or (and (not arg) (geiser--symbol-at-point)) - (geiser-completion--read-symbol "Edit symbol: "))) - (cmd `(:eval (:ge symbol-location ',symbol))) - (marker (point-marker)) - (ret (ignore-errors (geiser-eval--send/wait cmd)))) - (if (geiser-edit--try-edit symbol ret nil t) + (let ((symbol (or (and (not arg) (geiser--symbol-at-point)) + (geiser-completion--read-symbol "Edit symbol: "))) + (marker (point-marker))) + (if (geiser-edit--try-edit symbol (geiser-edit-symbol-location symbol) nil t) (when marker (xref-push-marker-stack marker)) (unless (geiser-edit-module-at-point t) (error "Couldn't find location for '%s'" symbol))) @@ -290,11 +293,20 @@ With prefix, asks for the symbol to locate." (with-no-warnings (xref-pop-marker-stack)))) -(defun geiser-edit-module (module &optional method no-error) +(defun geiser-edit-module-location (&optional module) + (let* ((module (or module + (geiser-completion--module-at-point) + (error "No module at point"))) + (cmd `(:eval (:ge module-location '(:module ,module))))) + (geiser-eval--retort-result (geiser-eval--send/wait cmd)))) + +(defun geiser-edit-module (&optional module method no-error) "Asks for a module and opens it in a new buffer." (interactive (list (geiser-completion--read-module))) - (let ((cmd `(:eval (:ge module-location '(:module ,module))))) - (geiser-edit--try-edit module (geiser-eval--send/wait cmd) method no-error))) + (geiser-edit--try-edit module + (geiser-edit-module-location module) + method + no-error)) (defun geiser-edit-module-at-point (&optional no-error) "Opens a new window visiting the module at point." diff --git a/elisp/geiser-eval.el b/elisp/geiser-eval.el index 8f58c25..069dfb9 100644 --- a/elisp/geiser-eval.el +++ b/elisp/geiser-eval.el @@ -1,6 +1,6 @@ ;;; geiser-eval.el --- Sending scheme code for evaluation -*- lexical-binding: t; -*- -;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2015, 2021, 2023 Jose Antonio Ortega Ruiz +;; Copyright (C) 2009-2013, 2015, 2021, 2023, 2026 Jose Antonio Ortega Ruiz ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the Modified BSD License. You should @@ -150,7 +150,8 @@ module-exports, autodoc, callers, callees and generic-methods.") (geiser-con--send-string (geiser-eval--connection) (geiser-eval--code-str code) (lambda (s) - (setq geiser-eval--async-retort (geiser-eval--log s)) + (setq geiser-eval--async-retort + (geiser-eval--log s)) (funcall cont s)) buffer)) @@ -167,6 +168,9 @@ module-exports, autodoc, callers, callees and generic-methods.") buffer) sync-retort)) +(defun geiser-eval--pending-requests-p () + (geiser-con--pending-requests-p (geiser-eval--connection))) + (defun geiser-eval-interrupt () "Interrupt on-going evaluation, if any." (interactive) diff --git a/elisp/geiser-impl.el b/elisp/geiser-impl.el index f95034a..e4b33d6 100644 --- a/elisp/geiser-impl.el +++ b/elisp/geiser-impl.el @@ -1,6 +1,6 @@ ;;; geiser-impl.el --- Generic support for scheme implementations -*- lexical-binding: t; -*- -;; Copyright (C) 2009-2010, 2012-2013, 2015-2016, 2019, 2021-2022 Jose Antonio Ortega Ruiz +;; Copyright (C) 2009-2010, 2012-2013, 2015-2016, 2019, 2021-2022, 2025 Jose Antonio Ortega Ruiz ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the Modified BSD License. You should @@ -143,9 +143,9 @@ in order to determine its scheme flavour." (push (cons impl file) geiser-impl--load-files))) ;;;###autoload -(progn ;Copy the whole def to the autoloads file. -(defun geiser-activate-implementation (impl) - (add-to-list 'geiser-active-implementations impl))) +(progn ;Copy the whole def to the autoloads file. + (defun geiser-activate-implementation (impl) + (add-to-list 'geiser-active-implementations impl))) (defsubst geiser-deactivate-implementation (impl) (setq geiser-active-implementations diff --git a/elisp/geiser-mode.el b/elisp/geiser-mode.el index c8a9e0d..75162d4 100644 --- a/elisp/geiser-mode.el +++ b/elisp/geiser-mode.el @@ -1,6 +1,6 @@ ;;; geiser-mode.el --- Minor mode for scheme buffers -*- lexical-binding: t; -*- -;; Copyright (C) 2009-2017, 2020, 2022, 2024 Jose Antonio Ortega Ruiz +;; Copyright (C) 2009-2017, 2020, 2022, 2024, 2025 Jose Antonio Ortega Ruiz ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the Modified BSD License. You should @@ -244,16 +244,15 @@ With prefix, recursively macro-expand the resulting expression." all t)) -(defun geiser-set-scheme () +(defun geiser-set-scheme (impl) "Associates current buffer with a given Scheme implementation." - (interactive) + (interactive (list (geiser-impl--read-impl))) (save-excursion (geiser-syntax--remove-kws) - (let ((impl (geiser-impl--read-impl))) - (geiser-impl--set-buffer-implementation impl) - (geiser-repl--set-up-repl impl) - (geiser-syntax--add-kws) - (geiser-syntax--fontify)))) + (geiser-impl--set-buffer-implementation impl) + (geiser-repl--set-up-repl impl) + (geiser-syntax--add-kws) + (geiser-syntax--fontify))) (defun geiser-mode-switch-to-repl (arg) "Switches to Geiser REPL. diff --git a/elisp/geiser-repl.el b/elisp/geiser-repl.el index b8df566..c43b9b2 100644 --- a/elisp/geiser-repl.el +++ b/elisp/geiser-repl.el @@ -1,6 +1,6 @@ ;;; geiser-repl.el --- Geiser's REPL -*- lexical-binding: t; -*- -;; Copyright (C) 2009-2013, 2015-2016, 2018-2023 Jose Antonio Ortega Ruiz +;; Copyright (C) 2009-2013, 2015-2016, 2018-2023, 2026 Jose Antonio Ortega Ruiz ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the Modified BSD License. You should @@ -235,12 +235,30 @@ See also `geiser-repl-startup-hook'." "The character that represents a closing super parentheses." :type 'character) +(geiser-custom--defcustom geiser-repl-classify-output-p nil + "Whether to classify REPL output by type (success/warning/error). + +When enabled, REPL output will be colored differently based on +whether it represents successful evaluation, a warning, or an error. +This classification is based on pattern matching of the output." + :type 'boolean) + + (geiser-custom--defface repl-input 'comint-highlight-input geiser-repl "evaluated input highlighting") (geiser-custom--defface repl-output 'font-lock-string-face geiser-repl "REPL output") +(geiser-custom--defface repl-output-success + 'font-lock-string-face geiser-repl "REPL output (success)") + +(geiser-custom--defface repl-output-warning + 'warning geiser-repl "REPL output (warnings)") + +(geiser-custom--defface repl-output-error + 'error geiser-repl "REPL output (errors)") + (geiser-custom--defface repl-prompt 'comint-highlight-prompt geiser-repl "REPL prompt") @@ -465,21 +483,55 @@ will be set up using `geiser-connect-local' when a REPL is started.") (setq header-line-format (format "Socket: %s" address))))) + +(defun geiser-repl--classify-output (start end) + "Classify output region as :success, :warning, or :error. +Returns the classification based on the first line of output. +Only used when `geiser-repl-classify-output-p' is non-nil." + (save-excursion + (goto-char start) + (let ((first-line (buffer-substring-no-properties + start + (min end (line-end-position))))) + (cond + ((string-match-p "raise-exception" first-line) :error) + ((string-match-p "warning:" first-line) :warning) + (t :success))))) + (defun geiser-repl--fontify-output-region (beg end) - "Apply highlighting to a REPL output region." + "Apply highlighting to a REPL output region. +If `geiser-repl-highlight-output-p' is enabled, applies syntax +highlighting. Otherwise, if `geiser-repl-classify-output-p' is +enabled, classifies output and applies appropriate face. If neither +is enabled, applies default output face." (remove-text-properties beg end '(font-lock-face nil face nil)) - (if geiser-repl-highlight-output-p - (geiser-syntax--fontify-syntax-region beg end) - (geiser-repl--fontify-plaintext beg end))) - -(defun geiser-repl--fontify-plaintext (start end) - "Fontify REPL output plainly." - (add-text-properties - start end - '(font-lock-fontified t - fontified t - font-lock-multiline t - font-lock-face geiser-font-lock-repl-output))) + (cond + (geiser-repl-highlight-output-p + (geiser-syntax--fontify-syntax-region beg end)) + (geiser-repl-classify-output-p + (let ((output-type (geiser-repl--classify-output beg end))) + (geiser-repl--fontify-plaintext beg end output-type))) + (t + (geiser-repl--fontify-plaintext beg end)))) + +(defun geiser-repl--fontify-plaintext (start end &optional output-type) + "Fontify REPL output plainly with appropriate face. +If OUTPUT-TYPE is provided and `geiser-repl-classify-output-p' is +enabled, it can be :success, :warning, or :error. Otherwise defaults +to standard output face." + (let ((face (if (and output-type geiser-repl-classify-output-p) + (pcase output-type + (:error 'geiser-font-lock-repl-output-error) + (:warning 'geiser-font-lock-repl-output-warning) + (:success 'geiser-font-lock-repl-output-success) + (_ 'geiser-font-lock-repl-output)) + 'geiser-font-lock-repl-output))) + (add-text-properties + start end + `(font-lock-fontified t + fontified t + font-lock-multiline t + font-lock-face ,face)))) (defun geiser-repl--narrow-to-prompt () "Narrow to active prompt region and return t, otherwise returns nil." @@ -533,13 +585,21 @@ will be set up using `geiser-connect-local' when a REPL is started.") (geiser--font-lock-ensure geiser-repl--last-output-start geiser-repl--last-output-end))) +(defun geiser-repl--matches-prompt-p (txt) + (or (string-match-p + (geiser-con--connection-prompt geiser-repl--connection) + txt) + (string-match-p + (geiser-con--connection-debug-prompt geiser-repl--connection) + txt))) + (defun geiser-repl--output-filter (txt) (when (geiser-repl--find-output-region) (geiser-repl--treat-output-region)) (geiser-con--connection-update-debugging geiser-repl--connection txt) (geiser-image--replace-images geiser-repl-inline-images-p geiser-repl-auto-display-images-p) - (when (string-match-p (geiser-con--connection-prompt geiser-repl--connection) - txt) + (when (geiser-repl--matches-prompt-p txt) + (geiser-con--connection-activate geiser-repl--connection) (geiser-autodoc--disinhibit-autodoc))) (defun geiser-repl--check-version (impl) @@ -697,14 +757,16 @@ will be set up using `geiser-connect-local' when a REPL is started.") "Send CMD input string to the current REPL buffer. If SAVE-HISTORY is non-nil, save CMD in the REPL history." (when (and cmd (eq major-mode 'geiser-repl-mode)) - (geiser-repl--prepare-send) - (goto-char (point-max)) - (comint-kill-input) - (insert cmd) - (let ((comint-input-filter (if save-history - comint-input-filter - 'ignore))) - (comint-send-input nil t)))) + (if (geiser-eval--pending-requests-p) + (message "Waiting for scheme process...") + (geiser-repl--prepare-send) + (goto-char (point-max)) + (comint-kill-input) + (insert cmd) + (let ((comint-input-filter (if save-history + comint-input-filter + 'ignore))) + (comint-send-input nil t))))) (defun geiser-repl-interrupt () (interactive) @@ -1100,7 +1162,7 @@ buffer." (geiser-repl-autoeval-mode 1)) (when geiser-repl-superparen-mode-p (geiser-repl-superparen-mode 1)) - + (add-hook 'comint-preoutput-filter-functions #'geiser--strip-ansi nil t) ;; enabling compilation-shell-minor-mode without the annoying highlighter (compilation-setup t)) diff --git a/elisp/geiser-syntax.el b/elisp/geiser-syntax.el index af750fb..683d37e 100644 --- a/elisp/geiser-syntax.el +++ b/elisp/geiser-syntax.el @@ -438,7 +438,8 @@ implementation-specific entries for font-lock-keywords.") (not bns)))) (when name (push name locals)) (when (geiser-syntax--symbol-eq head 'case-lambda) - (dolist (n (and (> nesting 0) (caar (last form)))) + (dolist (n (and (> nesting 0) + (geiser-syntax--linearize (caar (last form))))) (when n (push n locals))) (setq rest (and (> nesting 0) (cdr form))) (setq use-names nil)) diff --git a/elisp/geiser.el b/elisp/geiser.el index a7aabb9..6f92bf4 100644 --- a/elisp/geiser.el +++ b/elisp/geiser.el @@ -1,6 +1,6 @@ ;;; geiser.el --- GNU Emacs and Scheme talk to each other -*- lexical-binding: t; -*- -;; Copyright (C) 2009-2013, 2015, 2018, 2021-2024 Jose Antonio Ortega Ruiz +;; Copyright (C) 2009-2013, 2015, 2018, 2021-2026 Jose Antonio Ortega Ruiz ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the Modified BSD License. You should @@ -13,7 +13,7 @@ ;; Homepage: https://gitlab.com/emacs-geiser/ ;; Package-Requires: ((emacs "27.1") (project "0.8.1")) ;; SPDX-License-Identifier: BSD-3-Clause -;; Version: 0.31.1 +;; Version: 0.33.1 ;;; Commentary: |