guile/emacs/gds-scheme.el

;;; gds-scheme.el -- GDS function for Scheme mode buffers

;;;; Copyright (C) 2005 Neil Jerram
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later
;;;; version.
;;;; 
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;;; 02111-1307 USA

(require 'comint)
(require 'scheme)
(require 'derived)
(require 'pp)

;;;; Maintaining an association between a Guile client process and a
;;;; set of Scheme mode buffers.

(defcustom gds-auto-create-utility-client t
  "Whether to automatically create a utility Guile client, and
associate the current buffer with it, if there are no existing Guile
clients available to GDS when the user does something that requires a
running Guile client."
  :type 'boolean
  :group 'gds)

(defcustom gds-auto-associate-single-client t
  "Whether to automatically associate the current buffer with an
existing Guile client, if there is only only client known to GDS when
the user does something that requires a running Guile client, and the
current buffer is not already associated with a Guile client."
  :type 'boolean
  :group 'gds)

(defcustom gds-auto-associate-last-client t
  "Whether to automatically associate the current buffer with the
Guile client that most recently caused that buffer to be displayed,
when the user does something that requires a running Guile client and
the current buffer is not already associated with a Guile client."
  :type 'boolean
  :group 'gds)

(defvar gds-last-touched-by nil
  "For each Scheme mode buffer, this records the GDS client that most
recently `touched' that buffer in the sense of using it to display
source code, for example for the source code relevant to a debugger
stack frame.")
(make-variable-buffer-local 'gds-last-touched-by)

(defun gds-auto-associate-buffer ()
  "Automatically associate the current buffer with a Guile client, if
possible."
  (let* ((num-clients (length gds-client-info))
	 (client
	  (or
	   ;; If there are no clients yet, and
	   ;; `gds-auto-create-utility-client' allows us to create one
	   ;; automatically, do that.
	   (and (= num-clients 0)
		gds-auto-create-utility-client
		(gds-start-utility-guile))
	   ;; Otherwise, if there is a single existing client, and
	   ;; `gds-auto-associate-single-client' allows us to use it
	   ;; for automatic association, do that.
	   (and (= num-clients 1)
		gds-auto-associate-single-client
		(caar gds-client-info))
	   ;; Otherwise, if the current buffer was displayed because
	   ;; of a Guile client trapping somewhere in its code, and
	   ;; `gds-auto-associate-last-client' allows us to associate
	   ;; with that client, do so.
	   (and gds-auto-associate-last-client
		gds-last-touched-by))))
    (if client
	(gds-associate-buffer client))))	 

(defun gds-associate-buffer (client)
  "Associate the current buffer with the Guile process CLIENT.
This means that operations in this buffer that require a running Guile
process - such as evaluation, help, completion and setting traps -
will be sent to the Guile process whose name or connection number is
CLIENT."
  (interactive (list (gds-choose-client)))
  ;; If this buffer is already associated, dissociate from its
  ;; existing client first.
  (if gds-client (gds-dissociate-buffer))
  ;; Store the client number in the buffer-local variable gds-client.
  (setq gds-client client)
  ;; Add this buffer to the list of buffers associated with the
  ;; client.
  (gds-client-put client 'associated-buffers
		  (cons (current-buffer)
			(gds-client-get client 'associated-buffers))))

(defun gds-dissociate-buffer ()
  "Dissociate the current buffer from any specific Guile process."
  (interactive)
  (if gds-client
      (progn
        ;; Remove this buffer from the list of buffers associated with
        ;; the current client.
	(gds-client-put gds-client 'associated-buffers
			(delq (current-buffer)
			      (gds-client-get gds-client 'associated-buffers)))
        ;; Reset the buffer-local variable gds-client.
        (setq gds-client nil)
        ;; Clear any process status indication from the modeline.
        (setq mode-line-process nil)
        (force-mode-line-update))))

(defun gds-show-client-status (client status-string)
  "Show a client's status in the modeline of all its associated
buffers."
  (let ((buffers (gds-client-get client 'associated-buffers)))
    (while buffers
      (if (buffer-live-p (car buffers))
          (with-current-buffer (car buffers)
            (setq mode-line-process status-string)
            (force-mode-line-update)))
      (setq buffers (cdr buffers)))))

(defcustom gds-running-text ":running"
  "*Mode line text used to show that a Guile process is \"running\".
\"Running\" means that the process cannot currently accept any input
from the GDS frontend in Emacs, because all of its threads are busy
running code that GDS cannot easily interrupt."
  :type 'string
  :group 'gds)

(defcustom gds-ready-text ":ready"
  "*Mode line text used to show that a Guile process is \"ready\".
\"Ready\" means that the process is ready to interact with the GDS
frontend in Emacs, because at least one of its threads is waiting for
GDS input."
  :type 'string
  :group 'gds)

(defcustom gds-debug-text ":debug"
  "*Mode line text used to show that a Guile process is \"debugging\".
\"Debugging\" means that the process is using the GDS frontend in
Emacs to display an error or trap so that the user can debug it."
  :type 'string
  :group 'gds)

(defun gds-choose-client ()
  "Ask the user to choose a GDS client process from a list."
  (let ((table '())
        (default nil))
    ;; Prepare a table containing all current clients.
    (mapcar (lambda (client-info)
               (setq table (cons (cons (cadr (memq 'name client-info))
				       (car client-info))
				 table)))
             gds-client-info)
    ;; Add an entry to allow the user to ask for a new process.
    (setq table (cons (cons "Start a new Guile process" nil) table))
    ;; Work out a good default.  If the buffer has a good value in
    ;; gds-last-touched-by, we use that; otherwise default to starting
    ;; a new process.
    (setq default (or (and gds-last-touched-by
                           (gds-client-get gds-last-touched-by 'name))
                      (caar table)))
    ;; Read using this table.
    (let* ((name (completing-read "Choose a Guile process: "
                                  table
                                  nil
                                  t     ; REQUIRE-MATCH
                                  nil   ; INITIAL-INPUT
                                  nil   ; HIST
                                  default))
           ;; Convert name to a client number.
           (client (cdr (assoc name table))))
      ;; If the user asked to start a new Guile process, do that now.
      (or client (setq client (gds-start-utility-guile)))
      ;; Return the chosen client ID.
      client)))

(defvar gds-last-utility-number 0
  "Number of the last started Guile utility process.")

(defun gds-start-utility-guile ()
  "Start a new utility Guile process."
  (setq gds-last-utility-number (+ gds-last-utility-number 1))
  (let* ((procname (format "gds-util[%d]" gds-last-utility-number))
         (code (format "(begin
                          %s
                          (use-modules (ice-9 gds-client))
                          (run-utility))"
		       (if gds-scheme-directory
			   (concat "(set! %load-path (cons "
				   (format "%S" gds-scheme-directory)
				   " %load-path))")
			 "")))
         (proc (start-process procname
                              (get-buffer-create procname)
                              gds-guile-program
                              "-q"
                              "--debug"
                              "-c"
                              code))
         (client nil))
    ;; Note that this process can be killed automatically on Emacs
    ;; exit.
    (process-kill-without-query proc)
    ;; Set up a process filter to catch the new client's number.
    (set-process-filter proc
                        (lambda (proc string)
                          (setq client (string-to-number string))
                          (if (process-buffer proc)
                              (with-current-buffer (process-buffer proc)
                                (insert string)))))
    ;; Accept output from the new process until we have its number.
    (while (not client)
      (accept-process-output proc))
    ;; Return the new process's client number.
    client))

;;;; Evaluating code.

;; The following commands send code for evaluation through the GDS TCP
;; connection, receive the result and any output generated through the
;; same connection, and display the result and output to the user.
;;
;; For each buffer where evaluations can be requested, GDS uses the
;; buffer-local variable `gds-client' to track which GDS client
;; program should receive and handle that buffer's evaluations.

(defun gds-module-name (start end)
  "Determine and return the name of the module that governs the
specified region.  The module name is returned as a list of symbols."
  (interactive "r")			; why not?
  (save-excursion
    (goto-char start)
    (let (module-name)
      (while (and (not module-name)
		  (beginning-of-defun-raw 1))
	(if (looking-at "(define-module ")
	    (setq module-name
		  (progn
		    (goto-char (match-end 0))
		    (read (current-buffer))))))
      module-name)))

(defcustom gds-emacs-buffer-port-name-prefix "Emacs buffer: "
  "Prefix used when telling Guile the name of the port from which a
chunk of Scheme code (to be evaluated) comes.  GDS uses this prefix,
followed by the buffer name, in two cases: when the buffer concerned
is not associated with a file, or if the buffer has been modified
since last saving to its file.  In the case where the buffer is
identical to a saved file, GDS uses the file name as the port name."
  :type '(string)
  :group 'gds)

(defun gds-port-name (start end)
  "Return port name for the specified region of the current buffer.
The name will be used by Guile as the port name when evaluating that
region's code."
  (or (and (not (buffer-modified-p))
	   buffer-file-name)
      (concat gds-emacs-buffer-port-name-prefix (buffer-name))))

(defun gds-line-and-column (pos)
  "Return 0-based line and column number at POS."
  (let (line column)
    (save-excursion
      (goto-char pos)
      (setq column (current-column))
      (beginning-of-line)
      (setq line (count-lines (point-min) (point))))
    (cons line column)))

(defun gds-eval-region (start end &optional debugp)
  "Evaluate the current region.  If invoked with `C-u' prefix (or, in
a program, with optional DEBUGP arg non-nil), pause and pop up the
stack at the start of the evaluation, so that the user can single-step
through the code."
  (interactive "r\nP")
  (or gds-client
      (gds-auto-associate-buffer)
      (call-interactively 'gds-associate-buffer))
  (let ((module (gds-module-name start end))
	(port-name (gds-port-name start end))
	(lc (gds-line-and-column start)))
    (let ((code (buffer-substring-no-properties start end)))
      (gds-send (format "eval (region . %S) %s %S %d %d %S %s"
			(gds-abbreviated code)
			(if module (prin1-to-string module) "#f")
			port-name (car lc) (cdr lc)
			code
			(if debugp '(debug) '(none)))
		gds-client))))

(defun gds-eval-expression (expr &optional correlator debugp)
  "Evaluate the supplied EXPR (a string).  If invoked with `C-u'
prefix (or, in a program, with optional DEBUGP arg non-nil), pause and
pop up the stack at the start of the evaluation, so that the user can
single-step through the code."
  (interactive "sEvaluate expression: \ni\nP")
  (or gds-client
      (gds-auto-associate-buffer)
      (call-interactively 'gds-associate-buffer))
  (set-text-properties 0 (length expr) nil expr)
  (gds-send (format "eval (%S . %S) #f \"Emacs expression\" 0 0 %S %s"
		    (or correlator 'expression)
		    (gds-abbreviated expr)
		    expr
		    (if debugp '(debug) '(none)))
	    gds-client))

(defconst gds-abbreviated-length 35)

(defun gds-abbreviated (code)
  (let ((nlpos (string-match (regexp-quote "\n") code)))
    (while nlpos
      (setq code
	    (if (= nlpos (- (length code) 1))
		(substring code 0 nlpos)
	      (concat (substring code 0 nlpos)
		      "\\n"
		      (substring code (+ nlpos 1)))))
      (setq nlpos (string-match (regexp-quote "\n") code))))
  (if (> (length code) gds-abbreviated-length)
      (concat (substring code 0 (- gds-abbreviated-length 3)) "...")
    code))

(defun gds-eval-defun (&optional debugp)
  "Evaluate the defun (top-level form) at point.  If invoked with
`C-u' prefix (or, in a program, with optional DEBUGP arg non-nil),
pause and pop up the stack at the start of the evaluation, so that the
user can single-step through the code."
  (interactive "P")
  (save-excursion
   (end-of-defun)
   (let ((end (point)))
     (beginning-of-defun)
     (gds-eval-region (point) end debugp))))

(defun gds-eval-last-sexp (&optional debugp)
  "Evaluate the sexp before point.  If invoked with `C-u' prefix (or,
in a program, with optional DEBUGP arg non-nil), pause and pop up the
stack at the start of the evaluation, so that the user can single-step
through the code."
  (interactive "P")
  (gds-eval-region (save-excursion (backward-sexp) (point)) (point) debugp))

;;;; Help.

;; Help is implemented as a special case of evaluation, identified by
;; the evaluation correlator 'help.

(defun gds-help-symbol (sym)
  "Get help for SYM (a Scheme symbol)."
  (interactive
   (let ((sym (thing-at-point 'symbol))
	 (enable-recursive-minibuffers t)
	 val)
     (setq val (read-from-minibuffer
		(if sym
		    (format "Describe Guile symbol (default %s): " sym)
		  "Describe Guile symbol: ")))
     (list (if (zerop (length val)) sym val))))
  (gds-eval-expression (format "(help %s)" sym) 'help))

(defun gds-apropos (regex)
  "List Guile symbols matching REGEX."
  (interactive
   (let ((sym (thing-at-point 'symbol))
	 (enable-recursive-minibuffers t)
	 val)
     (setq val (read-from-minibuffer
		(if sym
		    (format "Guile apropos (regexp, default \"%s\"): " sym)
		  "Guile apropos (regexp): ")))
     (list (if (zerop (length val)) sym val))))
  (set-text-properties 0 (length regex) nil regex)
  (gds-eval-expression (format "(apropos %S)" regex) 'apropos))

;;;; Displaying results of help and eval.

(defun gds-display-results (client correlator stack-available results)
  (let* ((helpp+bufname (cond ((eq (car correlator) 'help)
                               '(t . "*Guile Help*"))
                              ((eq (car correlator) 'apropos)
                               '(t . "*Guile Apropos*"))
                              (t
                               '(nil . "*Guile Evaluation*"))))
         (helpp (car helpp+bufname)))
    (let ((buf (get-buffer-create (cdr helpp+bufname))))
      (save-selected-window
	(save-excursion
	  (set-buffer buf)
	  (gds-dissociate-buffer)
	  (erase-buffer)
	  (scheme-mode)
	  (insert (cdr correlator) "\n\n")
	  (while results
	    (insert (car results))
	    (or (bolp) (insert "\\\n"))
	    (if helpp
		nil
	      (if (cadr results)
		  (mapcar (function (lambda (value)
				      (insert " => " value "\n")))
			  (cadr results))
		(insert " => no (or unspecified) value\n"))
	      (insert "\n"))
	    (setq results (cddr results)))
	  (if stack-available
	      (let ((beg (point))
		    (map (make-sparse-keymap)))
		(define-key map [mouse-1] 'gds-show-last-stack)
		(define-key map "\C-m" 'gds-show-last-stack)
		(insert "[click here to show error stack]")
		(add-text-properties beg (point)
				     (list 'keymap map
					   'mouse-face 'highlight))
		(insert "\n")))
	  (goto-char (point-min))
	  (gds-associate-buffer client))
	(pop-to-buffer buf)
	(run-hooks 'temp-buffer-show-hook)))))

(defun gds-show-last-stack ()
  "Show stack of the most recent error."
  (interactive)
  (or gds-client
      (gds-auto-associate-buffer)
      (call-interactively 'gds-associate-buffer))
  (gds-send "debug-lazy-trap-context" gds-client))

;;;; Completion.

(defvar gds-completion-results nil)

(defun gds-complete-symbol ()
  "Complete the Guile symbol before point.  Returns `t' if anything
interesting happened, `nil' if not."
  (interactive)
  (or gds-client
      (gds-auto-associate-buffer)
      (call-interactively 'gds-associate-buffer))
  (let* ((chars (- (point) (save-excursion
			     (while (let ((syntax (char-syntax (char-before (point)))))
				      (or (eq syntax ?w) (eq syntax ?_)))
			       (forward-char -1))
			     (point)))))
    (if (zerop chars)
	nil
      (setq gds-completion-results nil)
      (gds-send (format "complete %s"
			(prin1-to-string
			 (buffer-substring-no-properties (- (point) chars)
							 (point))))
		 gds-client)
      (while (null gds-completion-results)
	(accept-process-output gds-debug-server 0 200))
      (cond ((eq gds-completion-results 'error)
             (error "Internal error - please report the contents of the *Guile Evaluation* window"))
	    ((eq gds-completion-results t)
	     nil)
	    ((stringp gds-completion-results)
	     (if (<= (length gds-completion-results) chars)
		 nil
	       (insert (substring gds-completion-results chars))
	       (message "Sole completion")
	       t))
	    ((= (length gds-completion-results) 1)
	     (if (<= (length (car gds-completion-results)) chars)
		 nil
	       (insert (substring (car gds-completion-results) chars))
	       t))
	    (t
	     (with-output-to-temp-buffer "*Completions*"
	       (display-completion-list gds-completion-results))
	     t)))))

;;;; Dispatcher for non-debug protocol.

(defun gds-nondebug-protocol (client proc args)
  (cond (;; (eval-results ...) - Results of evaluation.
         (eq proc 'eval-results)
         (gds-display-results client (car args) (cadr args) (cddr args))
         ;; If these results indicate an error, set
         ;; gds-completion-results to non-nil in case the error arose
         ;; when trying to do a completion.
         (if (eq (caar args) 'error)
             (setq gds-completion-results 'error)))

        (;; (completion-result ...) - Available completions.
         (eq proc 'completion-result)
         (setq gds-completion-results (or (car args) t)))

	(;; (note ...) - For debugging only.
	 (eq proc 'note))

        (;; (trace ...) - Tracing.
         (eq proc 'trace)
         (with-current-buffer (get-buffer-create "*GDS Trace*")
           (save-excursion
             (goto-char (point-max))
             (or (bolp) (insert "\n"))
             (insert "[client " (number-to-string client) "] " (car args) "\n"))))

        (t
         ;; Unexpected.
         (error "Bad protocol: %S" form))))
  
;;;; Scheme mode keymap items.

(define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun)
(define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp)
(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression)
(define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region)
(define-key scheme-mode-map "\C-hg" 'gds-help-symbol)
(define-key scheme-mode-map "\C-h\C-g" 'gds-apropos)
(define-key scheme-mode-map "\C-hG" 'gds-apropos)
(define-key scheme-mode-map "\C-hS" 'gds-show-last-stack)
(define-key scheme-mode-map "\e\t" 'gds-complete-symbol)

;;;; The end!

(provide 'gds-scheme)

;;; gds-scheme.el ends here.