Support for multiple Scheme implementations, Chapter 2.

 * The REPL is aware of multiple implementations...
 * and it knows how to create more than one connection for guile;
 * but it's not been tested with more than one implementation.
 * geiser-mode seems to be able to keep track of active REPLs.

1 files changed, 142 insertions, 79 deletions

diff --git a/elisp/geiser-repl.el b/elisp/geiser-repl.el
index 7232b99..7872eb0 100644
--- a/elisp/geiser-repl.el
+++ b/elisp/geiser-repl.el
@@ -82,65 +82,68 @@ REPL buffer."
   :group 'geiser-repl)
 
 
-;;; REPL history:
-
-(defun geiser-repl--sentinel (proc event)
-  (when (string= event "finished\n")
-    (with-current-buffer (process-buffer proc)
-      (let ((comint-input-ring-file-name geiser-repl-history-filename))
-        (comint-write-input-ring)
-        (when (buffer-name (current-buffer))
-          (insert "\nIt's been nice interacting with you!\n")
-          (insert "Press C-cz to bring me back.\n" ))))))
-
-(defun geiser-repl--input-filter (str)
-  (and (not (string-match "^\\s *$" str))
-       (not (string-match "^,quit *$" str))))
-
-(defun geiser-repl--history-setup ()
-  (set (make-local-variable 'comint-input-ring-file-name) geiser-repl-history-filename)
-  (set (make-local-variable 'comint-input-ring-size) geiser-repl-history-size)
-  (set (make-local-variable 'comint-input-filter) 'geiser-repl--input-filter)
-  (add-hook 'kill-buffer-hook 'comint-write-input-ring nil t)
-  (comint-read-input-ring t)
-  (set-process-sentinel (get-buffer-process (current-buffer)) 'geiser-repl--sentinel))
-
-
-;;; Geiser REPL buffer/process:
-
-(defvar geiser-repl--buffer nil
-  "The buffer in which the Guile REPL is running.")
-
-(defconst geiser-repl--prompt-regex "^[^() \n]+@([^)]*?)> ")
-
-(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)
-         (args `("-q" "-L" ,(concat geiser-scheme-dir "/guile/")))
-         (init-file (and geiser-repl-guile-init-file
-                         (expand-file-name geiser-repl-guile-init-file)))
-         (args (if (and init-file (file-readable-p init-file))
-                   `(,@args "-l" ,init-file)
-                 args)))
-    (message "Starting Geiser REPL ...")
-    (pop-to-buffer (geiser-repl--buffer))
-    (apply 'make-comint-in-buffer `("Geiser REPL" ,(current-buffer) ,guile nil ,@args))
+;;; Geiser REPL buffers and processes:
+
+(defvar geiser-repl--repls nil)
+
+(make-variable-buffer-local
+ (defvar geiser-repl--repl nil))
+
+(defsubst geiser-repl--this-buffer-repl ()
+  geiser-repl--repl)
+
+(defsubst geiser-repl--set-this-buffer-repl (r)
+  (setq geiser-repl--repl r))
+
+(defun geiser-repl--repl/impl (impl)
+  (catch 'repl
+    (dolist (repl geiser-repl--repls)
+      (with-current-buffer repl
+        (when (eq geiser-impl--implementation impl)
+          (throw 'repl repl))))))
+
+(defun geiser-repl--get-repl (&optional impl)
+  (or geiser-repl--repl
+      (setq geiser-repl--repl
+            (let ((impl (or impl
+                            geiser-impl--implementation
+                            (geiser-impl--guess))))
+              (when impl (geiser-repl--repl/impl impl))))))
+
+(defun geiser-repl--active-impls ()
+  (let ((act))
+    (dolist (repl geiser-repl--repls act)
+      (with-current-buffer repl
+        (add-to-list 'act geiser-impl--implementation)))))
+
+(defun geiser-repl--to-repl-buffer (impl)
+  (unless (and (eq major-mode 'geiser-repl-mode)
+               (not (get-buffer-process (current-buffer))))
+    (pop-to-buffer (generate-new-buffer (format "*Geiser REPL (%s)*" impl))))
+  (geiser-impl--set-buffer-implementation impl)
+  (geiser-repl-mode))
+
+(defun geiser-repl--start-repl (impl)
+  (message "Starting Geiser REPL for %s ..." impl)
+  (geiser-repl--to-repl-buffer impl)
+  (let ((binary (geiser-impl--binary impl))
+        (args (geiser-impl--parameters impl))
+        (prompt-rx (geiser-impl--prompt-regexp impl))
+        (cname (format "Geiser REPL (%s)" impl)))
+    (unless (and binary prompt-rx)
+      (error "Sorry, I don't know how to start a REPL for %s" impl))
+    (set (make-local-variable 'comint-prompt-regexp) prompt-rx)
+    (apply 'make-comint-in-buffer `(,cname ,(current-buffer) ,binary nil ,@args))
     (geiser-repl--wait-for-prompt 10000)
     (geiser-repl--history-setup)
-    (geiser-con--setup-connection (current-buffer)  geiser-repl--prompt-regex)))
+    (geiser-con--setup-connection (current-buffer) prompt-rx)
+    (add-to-list 'geiser-repl--repls (current-buffer))
+    (geiser-repl--set-this-buffer-repl (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))))
+(defun geiser-repl--process ()
+  (let ((buffer (geiser-repl--get-repl)))
+    (or (and (buffer-live-p buffer) (get-buffer-process buffer))
+        (error "No Geiser REPL for this buffer (try M-x run-geiser)"))))
 
 (setq geiser-eval--default-proc-function 'geiser-repl--process)
 
@@ -157,21 +160,42 @@ REPL buffer."
 
 ;;; Interface: starting and interacting with geiser REPL:
 
-(defalias 'switch-to-guile 'run-guile)
-
-(defun run-guile ()
-  "Run Geiser using Guile."
-  (interactive)
-  (geiser 'guile))
-
-(defun geiser (&optional implementation)
-  "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))))
+(defvar geiser-repl--impl-prompt-history nil)
+
+(defun geiser-repl--read-impl (prompt &optional active)
+  (car (read-from-string
+        (completing-read prompt
+                         (mapcar 'symbol-name
+                                 (if active
+                                     (geiser-repl--active-impls)
+                                   geiser-impl--impls))
+                         nil nil nil
+                         geiser-repl--impl-prompt-history
+                         (and (car geiser-impl--impls)
+                              (symbol-name (car geiser-impl--impls)))))))
+
+(defun run-geiser (impl)
+  "Start a new Geiser REPL."
+  (interactive
+   (list (geiser-repl--read-impl "Start Geiser for scheme implementation: ")))
+   (geiser-repl--start-repl impl))
+
+(defun switch-to-geiser (&optional ask impl)
+  "Switch to running Geiser REPL.
+With prefix argument, ask for which one if more than one is running.
+If no REPL is running, execute `run-geiser' to start a fresh one."
+  (interactive "P")
+  (let* ((repl (cond ((and (not ask) (not impl)
+                           (or (geiser-repl--this-buffer-repl)
+                               (car geiser-repl--repls))))
+                     ((and (not ask) impl (geiser-repl--repl/impl impl)))
+                     ((= 1 (length geiser-repl--repls)) (car geiser-repl--repls))))
+         (impl (or impl (and (not repl)
+                             (geiser-repl--read-impl "Switch to scheme REPL: "))))
+         (pop-up-windows geiser-repl-window-allow-split))
+    (if repl (pop-to-buffer repl) (run-geiser impl))))
+
+(defalias 'geiser 'switch-to-geiser)
 
 (defun geiser-repl-nuke ()
   "Try this command if the REPL becomes unresponsive."
@@ -182,6 +206,40 @@ REPL buffer."
   (geiser-con--setup-connection geiser-repl--buffer geiser-repl--prompt-regex))
 
 
+;;; REPL history and clean-up:
+
+(defun geiser-repl--on-quit ()
+  (comint-write-input-ring)
+  (let ((cb (current-buffer)))
+    (setq geiser-repl--repls (remove cb geiser-repl--repls))
+    (dolist (buffer (buffer-list))
+      (with-current-buffer buffer
+        (when (equal cb (geiser-repl--this-buffer-repl))
+          (geiser-repl--set-this-buffer-repl nil)
+          (geiser-repl--get-repl))))))
+
+(defun geiser-repl--sentinel (proc event)
+  (when (string= event "finished\n")
+    (with-current-buffer (process-buffer proc)
+      (let ((comint-input-ring-file-name geiser-repl-history-filename))
+        (geiser-repl--on-quit)
+        (when (buffer-name (current-buffer))
+          (insert "\nIt's been nice interacting with you!\n")
+          (insert "Press C-cz to bring me back.\n" ))))))
+
+(defun geiser-repl--input-filter (str)
+  (and (not (string-match "^\\s *$" str))
+       (not (string-match "^,quit *$" str))))
+
+(defun geiser-repl--history-setup ()
+  (set (make-local-variable 'comint-input-ring-file-name) geiser-repl-history-filename)
+  (set (make-local-variable 'comint-input-ring-size) geiser-repl-history-size)
+  (set (make-local-variable 'comint-input-filter) 'geiser-repl--input-filter)
+  (add-hook 'kill-buffer-hook 'geiser-repl--on-quit nil t)
+  (comint-read-input-ring t)
+  (set-process-sentinel (get-buffer-process (current-buffer)) 'geiser-repl--sentinel))
+
+
 ;;; geiser-repl mode:
 
 (defun geiser-repl--bol ()
@@ -200,14 +258,11 @@ REPL buffer."
   "Major mode for interacting with an inferior Guile repl process.
 \\{geiser-repl-mode-map}"
   (set (make-local-variable 'mode-line-process) nil)
-  (set (make-local-variable 'comint-prompt-regexp) geiser-repl--prompt-regex)
   (set (make-local-variable 'comint-use-prompt-regexp) t)
   (set (make-local-variable 'comint-prompt-read-only) t)
   (set (make-local-variable 'beginning-of-defun-function)
        'geiser-repl--beginning-of-defun)
   (set-syntax-table scheme-mode-syntax-table)
-  ;;; TODO: fix this call when we add support to multiple implementations
-  (geiser-impl--set-buffer-implementation)
   (setq geiser-eval--get-module-function 'geiser-repl--module-function)
   (when geiser-repl-autodoc-p (geiser-autodoc-mode 1)))
 
@@ -234,13 +289,21 @@ REPL buffer."
 
 ;;; Unload:
 
-(defun geiser-repl--live-p ()
-  (buffer-live-p geiser-repl--buffer))
+(defun geiser-repl--repl-list ()
+  (let (lst)
+    (dolist (repl geiser-repl--repls lst)
+      (when (buffer-live-p repl)
+        (with-current-buffer repl
+          (push geiser-impl--implementation) lst)))))
+
+(defun geiser-repl--restore (impls)
+  (dolist (impl impls)
+    (when impl (geiser impl))))
 
 (defun geiser-repl-unload-function ()
-  (when (geiser-repl--live-p)
-    (kill-buffer geiser-repl--buffer))
-  t)
+  (dolist (repl geiser-repl--repls)
+    (when (buffer-live-p repl)
+      (kill-buffer repl))))
 
 
 (provide 'geiser-repl)