diff options
Diffstat (limited to 'elisp')
| -rw-r--r-- | elisp/geiser-connection.el | 245 | ||||
| -rw-r--r-- | elisp/geiser-eval.el | 112 | ||||
| -rw-r--r-- | elisp/geiser-repl.el | 113 |
3 files changed, 470 insertions, 0 deletions
diff --git a/elisp/geiser-connection.el b/elisp/geiser-connection.el new file mode 100644 index 0000000..8091c84 --- /dev/null +++ b/elisp/geiser-connection.el @@ -0,0 +1,245 @@ +;; geiser-connection.el -- talking to a guile process + +;; Copyright (C) 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> +;; Start date: Sat Feb 07, 2009 21:11 + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Comentary: + +;; Connection datatype and functions for managing request queues +;; between emacs and inferior guile processes. + +;;; Code: + +(require 'geiser-log) +(require 'geiser-base) + +(require 'comint) +(require 'advice) + + +;;; Buffer connections: + +(make-variable-buffer-local + (defvar geiser-con--connection nil)) + +(defun geiser-con--get-connection (buffer/proc) + (if (processp buffer/proc) + (geiser-con--get-connection (process-buffer buffer/proc)) + (with-current-buffer buffer/proc geiser-con--connection))) + + +;;; Request datatype: + +(defun geiser-con--make-request (str cont &optional sender-buffer) + (list :geiser-connection-request + (cons :id (random)) + (cons :string str) + (cons :continuation cont) + (cons :buffer (or sender-buffer (current-buffer))))) + +(defsubst geiser-con--request-p (req) + (and (listp req) (eq (car req) :geiser-connection-request))) + +(defsubst geiser-con--request-id (req) + (cdr (assoc :id req))) + +(defsubst geiser-con--request-string (req) + (cdr (assoc :string req))) + +(defsubst geiser-con--request-continuation (req) + (cdr (assoc :continuation req))) + +(defsubst geiser-con--request-buffer (req) + (cdr (assoc :buffer req))) + +(defsubst geiser-con--request-deactivate (req) + (setcdr (assoc :continuation req) nil)) + +(defsubst geiser-con--request-deactivated-p (req) + (null (cdr (assoc :continuation req)))) + + +;;; Connection datatype: + +(defsubst geiser-con--make-connection (buffer) + (list :geiser-connection + (cons :requests (list)) + (cons :current nil) + (cons :completed (make-hash-table :weakness 'value)) + (cons :buffer buffer) + (cons :timer nil))) + +(defsubst geiser-con--connection-p (c) + (and (listp c) (eq (car c) :geiser-connection))) + +(defsubst geiser-con--connection-buffer (c) + (cdr (assoc :buffer c))) + +(defsubst geiser-con--connection-requests (c) + (cdr (assoc :requests c))) + +(defsubst geiser-con--connection-current-request (c) + (cdr (assoc :current c))) + +(defun geiser-con--connection-clean-current-request (c) + (let* ((cell (assoc :current c)) + (req (cdr cell))) + (when req + (puthash (geiser-con--request-id req) req (cdr (assoc :completed c))) + (setcdr cell nil)))) + +(defun geiser-con--connection-add-request (c r) + (let ((reqs (assoc :requests c))) + (setcdr reqs (append (cdr reqs) (list r))))) + +(defsubst geiser-con--connection-completed-p (c id) + (gethash id (cdr (assoc :completed c)))) + +(defun geiser-con--connection-pop-request (c) + (let ((reqs (assoc :requests c)) + (current (assoc :current c))) + (setcdr current (prog1 (cadr reqs) (setcdr reqs (cddr reqs)))) + (if (and (cdr current) + (geiser-con--request-deactivated-p (cdr current))) + (geiser-con--connection-pop-request c) + (cdr current)))) + +(defun geiser-con--connection-start-timer (c) + (let ((cell (assoc :timer c))) + (when (cdr cell) (cancel-timer (cdr cell))) + (setcdr cell (run-at-time t 0.5 'geiser-con--process-next c)))) + +(defun geiser-con--connection-cancel-timer (c) + (let ((cell (assoc :timer c))) + (when (cdr cell) (cancel-timer (cdr cell))))) + + +;;; Connection setup: + +(defun geiser-con--cleanup-connection (c) + (geiser-con--connection-cancel-timer c)) + +(defun geiser-con--setup-connection (buffer) + (with-current-buffer buffer + (when geiser-con--connection + (geiser-con--cleanup-connection geiser-con--connection)) + (setq geiser-con--connection (geiser-con--make-connection buffer)) + (geiser-con--setup-comint) + (geiser-con--connection-start-timer geiser-con--connection) + (message "Geiser REPL up and running!"))) + +(defconst geiser-con--prompt-regex "^[^() \n]+@([^)]*?)> ") + +(defun geiser-con--setup-comint () + (set (make-local-variable 'comint-redirect-insert-matching-regexp) nil) + (set (make-local-variable 'comint-redirect-finished-regexp) geiser-con--prompt-regex) + (add-hook 'comint-redirect-hook 'geiser-con--comint-redirect-hook nil t)) + + +;;; Requests handling: + +(defsubst geiser-con--comint-buffer () + (get-buffer-create " *geiser connection retort*")) + +(defun geiser-con--comint-buffer-form () + (with-current-buffer (geiser-con--comint-buffer) + (replace-string "#" ":" nil (point-min) (point-max)) + (goto-char (point-min)) + (condition-case nil + (let ((form (read (current-buffer)))) + (if (listp form) form (error))) + (error `((error geiser-con-error ,(buffer-string))))))) + +(defun geiser-con--process-next (con) + (when (not (geiser-con--connection-current-request con)) + (let* ((buffer (geiser-con--connection-buffer con)) + (req (geiser-con--connection-pop-request con)) + (str (and req (geiser-con--request-string req))) + (cbuf (with-current-buffer (geiser-con--comint-buffer) + (erase-buffer) + (current-buffer)))) + (if (not (buffer-live-p buffer)) + (geiser-con--connection-cancel-timer con) + (when (and buffer req str) + (set-buffer buffer) + (geiser-log--info "<%s>: %s" (geiser-con--request-id req) str) + (comint-redirect-send-command (format "%s" str) cbuf nil t)))))) + +(defun geiser-con--process-completed-request (req) + (let ((cont (geiser-con--request-continuation req)) + (id (geiser-con--request-id req)) + (rstr (geiser-con--request-string req)) + (buffer (geiser-con--request-buffer req))) + (if (not cont) + (geiser-log--warn "<%s> Droping result for request %S (%s)" + id rstr req) + (condition-case cerr + (with-current-buffer (or buffer (current-buffer)) + (funcall cont (geiser-con--comint-buffer-form)) + (geiser-log--info "<%s>: processed" id)) + (error (geiser-log--error + "<%s>: continuation failed %S \n\t%s" id rstr cerr)))))) + +(defun geiser-con--comint-redirect-hook () + (if (not geiser-con--connection) + (geiser-log--error "No connection in buffer") + (let ((req (geiser-con--connection-current-request geiser-con--connection))) + (if (not req) (geiser-log--error "No current request") + (geiser-con--process-completed-request req) + (geiser-con--connection-clean-current-request geiser-con--connection))))) + + +;;; Message sending interface: + +(defconst geiser-con--error-message "Geiser connection not active") + +(defun geiser-con--send-string (buffer/proc str cont &optional sender-buffer) + (save-current-buffer + (let ((con (geiser-con--get-connection buffer/proc))) + (unless con (error geiser-con--error-message)) + (let ((req (geiser-con--make-request str cont sender-buffer))) + (geiser-con--connection-add-request con req) + (geiser-con--process-next con) + req)))) + +(defvar geiser-connection-timeout 30000 + "Time limit, in msecs, blocking on synchronous evaluation requests") + +(defun geiser-con--send-string/wait (buffer/proc str cont &optional timeout sbuf) + (save-current-buffer + (let ((con (geiser-con--get-connection buffer/proc))) + (unless con (error geiser-con--error-message)) + (let* ((req (geiser-con--send-string buffer/proc str cont sbuf)) + (id (and req (geiser-con--request-id req))) + (time (or timeout geiser-connection-timeout)) + (step 100) + (waitsecs (/ step 1000.0))) + (when id + (condition-case nil + (while (and (> time 0) + (not (geiser-con--connection-completed-p con id))) + (accept-process-output nil waitsecs) + (setq time (- time step))) + (error (setq time 0))) + (or (> time 0) + (geiser-con--request-deactivate req) + nil)))))) + + +(provide 'geiser-connection) +;;; geiser-connection.el ends here diff --git a/elisp/geiser-eval.el b/elisp/geiser-eval.el new file mode 100644 index 0000000..74c9b29 --- /dev/null +++ b/elisp/geiser-eval.el @@ -0,0 +1,112 @@ +;; geiser-eval.el -- sending scheme code for evaluation + +;; Copyright (C) 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> +;; Start date: Sat Feb 07, 2009 22:35 + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Comentary: + +;; Functions, building on top of geiser-connection, to evaluate scheme +;; code. + +;;; Code: + +(require 'geiser-connection) +(require 'geiser-log) +(require 'geiser-base) + + +;;; Code formatting: + +(defun geiser-eval--scheme-str (code) + (cond ((null code) "'()") + ((eq code :f) "#f") + ((eq code :t) "#t") + ((listp code) + (cond ((eq (car code) :gs) (concat "((@ (geiser eval) eval-in) (quote " + (geiser-eval--scheme-str (nth 1 code)) + ") " + (or (nth 2 code) + (geiser-eval--buffer-module)) + ")")) + ((eq (car code) :scm) (cadr code)) + (t (concat "(" (mapconcat 'geiser-eval--scheme-str code " ") ")")))) + (t (format "%S" code)))) + + +;;; Current module: + +(defun geiser-eval--buffer-module (&optional buffer) + (let ((buffer (or buffer (current-buffer)))) + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "(define-module +\\(([^)]+)\\)" nil t) + (match-string-no-properties 1) + "#f"))))) + + +;;; Code sending: + +(defvar geiser-eval--default-proc-function nil) + +(defsubst geiser-eval--default-proc () + (and geiser-eval--default-proc-function + (funcall geiser-eval--default-proc-function))) + +(defvar geiser-eval--proc nil) + +(defsubst geiser-eval--proc () + (or geiser-eval--proc (geiser-eval--default-proc))) + +(defsubst geiser-eval--log (s) + (geiser-log--info "RETORT: %S" s) + s) + +(defsubst geiser-eval--code-str (code) + (if (stringp code) code (geiser-eval--scheme-str code))) + +(defvar geiser-eval--sync-retort nil) +(defun geiser-eval--set-sync-retort (s) + (setq geiser-eval--sync-retort (geiser-eval--log s))) + +(defun geiser-eval--send/wait (code &optional timeout buffer) + (setq geiser-eval--sync-retort nil) + (geiser-con--send-string/wait (geiser-eval--proc) + (geiser-eval--code-str code) + 'geiser-eval--set-sync-retort + timeout + buffer) + geiser-eval--sync-retort) + +(defsubst geiser-eval--send (code cont &optional buffer) + (geiser-con--send-string (geiser-eval--proc) + (geiser-eval--code-str code) + `(lambda (s) (,cont (geiser-eval--log s))) + buffer)) + + +;;; Retort parsing: + +(defsubst geiser-eval--retort-p (ret) + (and (listp ret) (or (assoc 'error ret) (assoc 'result ret)))) +(defsubst geiser-eval--retort-error (ret) (cdr (assoc 'error ret))) +(defsubst geiser-eval--retort-result (ret) (cdr (assoc 'result ret))) + + +(provide 'geiser-eval) +;;; geiser-eval.el ends here diff --git a/elisp/geiser-repl.el b/elisp/geiser-repl.el index 3c75cfc..1353019 100644 --- a/elisp/geiser-repl.el +++ b/elisp/geiser-repl.el @@ -25,16 +25,129 @@ ;;; Code: +(require 'geiser-eval) +(require 'geiser-connection) (require 'geiser-base) (require 'comint) ;;; Customization: +(defgroup geiser-repl nil + "Interacting with a Guile process inside Emacs." + :group 'geiser) + +(defcustom geiser-repl-guile-binary + (cond ((eq system-type 'windows-nt) "guile.exe") + ((eq system-type 'darwin) "guile") + (t "guile")) + "Name to use to call the guile executable when starting a REPL." + :type 'string + :group 'geiser-repl) + +(defcustom geiser-repl-use-other-window t + "Use a window other than the current buffer's when switching to +the Geiser REPL buffer." + :type 'boolean + :group 'geiser-repl) + +(defcustom geiser-repl-window-allow-split t + "Allow window splitting when switching to the Geiser REPL buffer." + :type 'boolean + :group 'geiser-repl) + + +;;; Geiser REPL buffer/process: + +(defvar geiser-repl--buffer nil + "The buffer in which the Guile REPL is running.") + +(defun geiser-repl--buffer () + (if (buffer-live-p geiser-repl--buffer) geiser-repl--buffer + (with-current-buffer (get-buffer-create "*Geiser REPL*") + (geiser-repl-mode) + (setq geiser-repl--buffer (current-buffer))))) + +(defun geiser-repl--start-process () + (let ((guile geiser-repl-guile-binary)) + (message "Starting Geiser REPL ...") + (pop-to-buffer (geiser-repl--buffer)) + (make-comint-in-buffer "Geiser REPL" + (current-buffer) + guile + nil + "-L" geiser-scheme-dir "-q") + (geiser-repl--wait-for-prompt 10000) + (geiser-con--setup-connection (current-buffer)))) + +(defun geiser-repl--process (&optional start) + (or (and (buffer-live-p (geiser-repl--buffer)) + (get-buffer-process (geiser-repl--buffer))) + (if (not start) + (error "No running Guile REPL (try M-x run-guile)") + (geiser-repl--start-process) + (geiser-repl--process)))) + +(setq geiser-eval--default-proc-function 'geiser-repl--process) + +(defun geiser-repl--wait-for-prompt (timeout) + (let ((p (point)) (seen)) + (while (and (not seen) (> timeout 0)) + (sleep-for 0.1) + (setq timeout (- timeout 100)) + (goto-char p) + (setq seen (re-search-forward comint-prompt-regexp nil t))) + (goto-char (point-max)) + (unless seen (error "No prompt found!")))) + + +;;; Interface: starting and interacting with geiser REPL: + +(defalias 'switch-to-guile 'run-guile) +(defalias 'switch-to-geiser-repl 'run-guile) + +(defun run-guile (&optional arg) + "Show the geiser-repl buffer, starting the process if needed." + (interactive) + (let ((buf (process-buffer (geiser-repl--process t))) + (pop-up-windows geiser-repl-window-allow-split)) + (if geiser-repl-use-other-window + (pop-to-buffer buf) + (switch-to-buffer buf)))) + +(defun geiser-repl-nuke () + "Try this command if the REPL becomes unresponsive." + (interactive) + (goto-char (point-max)) + (comint-kill-region comint-last-input-start (point)) + (comint-redirect-cleanup) + (geiser-con--setup-connection geiser-repl--buffer)) + ;;; geiser-repl mode: +(defun geiser-repl--bol () + (interactive) + (when (= (point) (comint-bol)) (beginning-of-line))) +;;;###autoload +(define-derived-mode geiser-repl-mode comint-mode "Geiser REPL" + "Major mode for interacting with an inferior Guile repl process. +\\{geiser-repl-mode-map}" + (set (make-local-variable 'comint-prompt-regexp) geiser-con--prompt-regex) + (set (make-local-variable 'comint-use-prompt-regexp) t) + (set (make-local-variable 'comint-prompt-read-only) t)) +(define-key geiser-repl-mode-map "\C-cz" 'run-guile) +(define-key geiser-repl-mode-map "\C-c\C-z" 'run-guile) +(define-key geiser-repl-mode-map "\C-a" 'geiser-repl--bol) +;; (define-key geiser-repl-mode-map "\C-ca" 'geiser-autodoc-mode) +;; (define-key geiser-repl-mode-map "\C-ch" 'geiser-help) +;; (define-key geiser-repl-mode-map "\C-cp" 'geiser-apropos) +;; (define-key geiser-repl-mode-map "\M-." 'geiser-edit-word-at-point) +;; (define-key geiser-repl-mode-map "\C-ck" 'geiser-compile-file) +;; (define-key geiser-repl-mode-map (kbd "TAB") 'geiser-completion--complete-symbol) + + (provide 'geiser-repl) ;;; geiser-repl.el ends here |