summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2009-02-08 01:09:07 +0100
committerJose Antonio Ortega Ruiz <jao@gnu.org>2009-02-08 01:09:07 +0100
commit377d6d19debce5572052727323931f1b8306226b (patch)
tree1db58005a4fb2ee285ef6688fa40ca98da5578fd
parent9b4016cd9bce8354ac3eede20345e83db8c65b94 (diff)
downloadgeiser-chez-377d6d19debce5572052727323931f1b8306226b.tar.gz
geiser-chez-377d6d19debce5572052727323931f1b8306226b.tar.bz2
Basic Guile/Emacs connection and evaluation working.
-rw-r--r--elisp/geiser-connection.el245
-rw-r--r--elisp/geiser-eval.el112
-rw-r--r--elisp/geiser-repl.el113
-rw-r--r--scheme/geiser/eval.scm42
4 files changed, 512 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
diff --git a/scheme/geiser/eval.scm b/scheme/geiser/eval.scm
new file mode 100644
index 0000000..3e800c9
--- /dev/null
+++ b/scheme/geiser/eval.scm
@@ -0,0 +1,42 @@
+;; eval.scm -- evaluation procedures
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Fri Feb 06, 2009 22:54
+
+;; 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:
+
+;; Module defining evaluation procedures called from the Emacs side.
+
+;;; Code:
+
+(define-module (geiser eval)
+ #:export (eval-in))
+
+(define (eval-in form module-name)
+ "Evals FORM in the module designated by MODULE-NAME.
+If MODULE-NAME is #f or resolution fails, the current module is used instead.
+The result is a list of the form ((RESULT . <form-value>))
+if no evaluation error happens, or ((ERROR <error-key> <error-arg>...))
+in case of errors."
+ (let ((module (or (and module-name (resolve-module module-name))
+ (current-module))))
+ (catch #t
+ (lambda () (list (cons 'result (eval form module))))
+ (lambda (key . args) (list (cons 'error (cons key args)))))))
+
+;;; eval.scm ends here