1;;; gds-scheme.el -- GDS function for Scheme mode buffers 2 3;;;; Copyright (C) 2005 Neil Jerram 4;;;; 5;;;; This library is free software; you can redistribute it and/or 6;;;; modify it under the terms of the GNU Lesser General Public 7;;;; License as published by the Free Software Foundation; either 8;;;; version 2.1 of the License, or (at your option) any later 9;;;; version. 10;;;; 11;;;; This library is distributed in the hope that it will be useful, 12;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14;;;; Lesser General Public License for more details. 15;;;; 16;;;; You should have received a copy of the GNU Lesser General Public 17;;;; License along with this library; if not, write to the Free 18;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 19;;;; 02111-1307 USA 20 21(require 'comint) 22(require 'scheme) 23(require 'derived) 24(require 'pp) 25 26;;;; Maintaining an association between a Guile client process and a 27;;;; set of Scheme mode buffers. 28 29(defcustom gds-auto-create-utility-client t 30 "Whether to automatically create a utility Guile client, and 31associate the current buffer with it, if there are no existing Guile 32clients available to GDS when the user does something that requires a 33running Guile client." 34 :type 'boolean 35 :group 'gds) 36 37(defcustom gds-auto-associate-single-client t 38 "Whether to automatically associate the current buffer with an 39existing Guile client, if there is only only client known to GDS when 40the user does something that requires a running Guile client, and the 41current buffer is not already associated with a Guile client." 42 :type 'boolean 43 :group 'gds) 44 45(defcustom gds-auto-associate-last-client t 46 "Whether to automatically associate the current buffer with the 47Guile client that most recently caused that buffer to be displayed, 48when the user does something that requires a running Guile client and 49the current buffer is not already associated with a Guile client." 50 :type 'boolean 51 :group 'gds) 52 53(defvar gds-last-touched-by nil 54 "For each Scheme mode buffer, this records the GDS client that most 55recently `touched' that buffer in the sense of using it to display 56source code, for example for the source code relevant to a debugger 57stack frame.") 58(make-variable-buffer-local 'gds-last-touched-by) 59 60(defun gds-auto-associate-buffer () 61 "Automatically associate the current buffer with a Guile client, if 62possible." 63 (let* ((num-clients (length gds-client-info)) 64 (client 65 (or 66 ;; If there are no clients yet, and 67 ;; `gds-auto-create-utility-client' allows us to create one 68 ;; automatically, do that. 69 (and (= num-clients 0) 70 gds-auto-create-utility-client 71 (gds-start-utility-guile)) 72 ;; Otherwise, if there is a single existing client, and 73 ;; `gds-auto-associate-single-client' allows us to use it 74 ;; for automatic association, do that. 75 (and (= num-clients 1) 76 gds-auto-associate-single-client 77 (caar gds-client-info)) 78 ;; Otherwise, if the current buffer was displayed because 79 ;; of a Guile client trapping somewhere in its code, and 80 ;; `gds-auto-associate-last-client' allows us to associate 81 ;; with that client, do so. 82 (and gds-auto-associate-last-client 83 gds-last-touched-by)))) 84 (if client 85 (gds-associate-buffer client)))) 86 87(defun gds-associate-buffer (client) 88 "Associate the current buffer with the Guile process CLIENT. 89This means that operations in this buffer that require a running Guile 90process - such as evaluation, help, completion and setting traps - 91will be sent to the Guile process whose name or connection number is 92CLIENT." 93 (interactive (list (gds-choose-client))) 94 ;; If this buffer is already associated, dissociate from its 95 ;; existing client first. 96 (if gds-client (gds-dissociate-buffer)) 97 ;; Store the client number in the buffer-local variable gds-client. 98 (setq gds-client client) 99 ;; Add this buffer to the list of buffers associated with the 100 ;; client. 101 (gds-client-put client 'associated-buffers 102 (cons (current-buffer) 103 (gds-client-get client 'associated-buffers)))) 104 105(defun gds-dissociate-buffer () 106 "Dissociate the current buffer from any specific Guile process." 107 (interactive) 108 (if gds-client 109 (progn 110 ;; Remove this buffer from the list of buffers associated with 111 ;; the current client. 112 (gds-client-put gds-client 'associated-buffers 113 (delq (current-buffer) 114 (gds-client-get gds-client 'associated-buffers))) 115 ;; Reset the buffer-local variable gds-client. 116 (setq gds-client nil) 117 ;; Clear any process status indication from the modeline. 118 (setq mode-line-process nil) 119 (force-mode-line-update)))) 120 121(defun gds-show-client-status (client status-string) 122 "Show a client's status in the modeline of all its associated 123buffers." 124 (let ((buffers (gds-client-get client 'associated-buffers))) 125 (while buffers 126 (if (buffer-live-p (car buffers)) 127 (with-current-buffer (car buffers) 128 (setq mode-line-process status-string) 129 (force-mode-line-update))) 130 (setq buffers (cdr buffers))))) 131 132(defcustom gds-running-text ":running" 133 "*Mode line text used to show that a Guile process is \"running\". 134\"Running\" means that the process cannot currently accept any input 135from the GDS frontend in Emacs, because all of its threads are busy 136running code that GDS cannot easily interrupt." 137 :type 'string 138 :group 'gds) 139 140(defcustom gds-ready-text ":ready" 141 "*Mode line text used to show that a Guile process is \"ready\". 142\"Ready\" means that the process is ready to interact with the GDS 143frontend in Emacs, because at least one of its threads is waiting for 144GDS input." 145 :type 'string 146 :group 'gds) 147 148(defcustom gds-debug-text ":debug" 149 "*Mode line text used to show that a Guile process is \"debugging\". 150\"Debugging\" means that the process is using the GDS frontend in 151Emacs to display an error or trap so that the user can debug it." 152 :type 'string 153 :group 'gds) 154 155(defun gds-choose-client () 156 "Ask the user to choose a GDS client process from a list." 157 (let ((table '()) 158 (default nil)) 159 ;; Prepare a table containing all current clients. 160 (mapcar (lambda (client-info) 161 (setq table (cons (cons (cadr (memq 'name client-info)) 162 (car client-info)) 163 table))) 164 gds-client-info) 165 ;; Add an entry to allow the user to ask for a new process. 166 (setq table (cons (cons "Start a new Guile process" nil) table)) 167 ;; Work out a good default. If the buffer has a good value in 168 ;; gds-last-touched-by, we use that; otherwise default to starting 169 ;; a new process. 170 (setq default (or (and gds-last-touched-by 171 (gds-client-get gds-last-touched-by 'name)) 172 (caar table))) 173 ;; Read using this table. 174 (let* ((name (completing-read "Choose a Guile process: " 175 table 176 nil 177 t ; REQUIRE-MATCH 178 nil ; INITIAL-INPUT 179 nil ; HIST 180 default)) 181 ;; Convert name to a client number. 182 (client (cdr (assoc name table)))) 183 ;; If the user asked to start a new Guile process, do that now. 184 (or client (setq client (gds-start-utility-guile))) 185 ;; Return the chosen client ID. 186 client))) 187 188(defvar gds-last-utility-number 0 189 "Number of the last started Guile utility process.") 190 191(defun gds-start-utility-guile () 192 "Start a new utility Guile process." 193 (setq gds-last-utility-number (+ gds-last-utility-number 1)) 194 (let* ((procname (format "gds-util[%d]" gds-last-utility-number)) 195 (code (format "(begin 196 %s 197 (use-modules (ice-9 gds-client)) 198 (run-utility))" 199 (if gds-scheme-directory 200 (concat "(set! %load-path (cons " 201 (format "%S" gds-scheme-directory) 202 " %load-path))") 203 ""))) 204 (proc (start-process procname 205 (get-buffer-create procname) 206 gds-guile-program 207 "-q" 208 "--debug" 209 "-c" 210 code)) 211 (client nil)) 212 ;; Note that this process can be killed automatically on Emacs 213 ;; exit. 214 (process-kill-without-query proc) 215 ;; Set up a process filter to catch the new client's number. 216 (set-process-filter proc 217 (lambda (proc string) 218 (setq client (string-to-number string)) 219 (if (process-buffer proc) 220 (with-current-buffer (process-buffer proc) 221 (insert string))))) 222 ;; Accept output from the new process until we have its number. 223 (while (not client) 224 (accept-process-output proc)) 225 ;; Return the new process's client number. 226 client)) 227 228;;;; Evaluating code. 229 230;; The following commands send code for evaluation through the GDS TCP 231;; connection, receive the result and any output generated through the 232;; same connection, and display the result and output to the user. 233;; 234;; For each buffer where evaluations can be requested, GDS uses the 235;; buffer-local variable `gds-client' to track which GDS client 236;; program should receive and handle that buffer's evaluations. 237 238(defun gds-module-name (start end) 239 "Determine and return the name of the module that governs the 240specified region. The module name is returned as a list of symbols." 241 (interactive "r") ; why not? 242 (save-excursion 243 (goto-char start) 244 (let (module-name) 245 (while (and (not module-name) 246 (beginning-of-defun-raw 1)) 247 (if (looking-at "(define-module ") 248 (setq module-name 249 (progn 250 (goto-char (match-end 0)) 251 (read (current-buffer)))))) 252 module-name))) 253 254(defcustom gds-emacs-buffer-port-name-prefix "Emacs buffer: " 255 "Prefix used when telling Guile the name of the port from which a 256chunk of Scheme code (to be evaluated) comes. GDS uses this prefix, 257followed by the buffer name, in two cases: when the buffer concerned 258is not associated with a file, or if the buffer has been modified 259since last saving to its file. In the case where the buffer is 260identical to a saved file, GDS uses the file name as the port name." 261 :type '(string) 262 :group 'gds) 263 264(defun gds-port-name (start end) 265 "Return port name for the specified region of the current buffer. 266The name will be used by Guile as the port name when evaluating that 267region's code." 268 (or (and (not (buffer-modified-p)) 269 buffer-file-name) 270 (concat gds-emacs-buffer-port-name-prefix (buffer-name)))) 271 272(defun gds-line-and-column (pos) 273 "Return 0-based line and column number at POS." 274 (let (line column) 275 (save-excursion 276 (goto-char pos) 277 (setq column (current-column)) 278 (beginning-of-line) 279 (setq line (count-lines (point-min) (point)))) 280 (cons line column))) 281 282(defun gds-eval-region (start end &optional debugp) 283 "Evaluate the current region. If invoked with `C-u' prefix (or, in 284a program, with optional DEBUGP arg non-nil), pause and pop up the 285stack at the start of the evaluation, so that the user can single-step 286through the code." 287 (interactive "r\nP") 288 (or gds-client 289 (gds-auto-associate-buffer) 290 (call-interactively 'gds-associate-buffer)) 291 (let ((module (gds-module-name start end)) 292 (port-name (gds-port-name start end)) 293 (lc (gds-line-and-column start))) 294 (let ((code (buffer-substring-no-properties start end))) 295 (gds-send (format "eval (region . %S) %s %S %d %d %S %s" 296 (gds-abbreviated code) 297 (if module (prin1-to-string module) "#f") 298 port-name (car lc) (cdr lc) 299 code 300 (if debugp '(debug) '(none))) 301 gds-client)))) 302 303(defun gds-eval-expression (expr &optional correlator debugp) 304 "Evaluate the supplied EXPR (a string). If invoked with `C-u' 305prefix (or, in a program, with optional DEBUGP arg non-nil), pause and 306pop up the stack at the start of the evaluation, so that the user can 307single-step through the code." 308 (interactive "sEvaluate expression: \ni\nP") 309 (or gds-client 310 (gds-auto-associate-buffer) 311 (call-interactively 'gds-associate-buffer)) 312 (set-text-properties 0 (length expr) nil expr) 313 (gds-send (format "eval (%S . %S) #f \"Emacs expression\" 0 0 %S %s" 314 (or correlator 'expression) 315 (gds-abbreviated expr) 316 expr 317 (if debugp '(debug) '(none))) 318 gds-client)) 319 320(defconst gds-abbreviated-length 35) 321 322(defun gds-abbreviated (code) 323 (let ((nlpos (string-match (regexp-quote "\n") code))) 324 (while nlpos 325 (setq code 326 (if (= nlpos (- (length code) 1)) 327 (substring code 0 nlpos) 328 (concat (substring code 0 nlpos) 329 "\\n" 330 (substring code (+ nlpos 1))))) 331 (setq nlpos (string-match (regexp-quote "\n") code)))) 332 (if (> (length code) gds-abbreviated-length) 333 (concat (substring code 0 (- gds-abbreviated-length 3)) "...") 334 code)) 335 336(defun gds-eval-defun (&optional debugp) 337 "Evaluate the defun (top-level form) at point. If invoked with 338`C-u' prefix (or, in a program, with optional DEBUGP arg non-nil), 339pause and pop up the stack at the start of the evaluation, so that the 340user can single-step through the code." 341 (interactive "P") 342 (save-excursion 343 (end-of-defun) 344 (let ((end (point))) 345 (beginning-of-defun) 346 (gds-eval-region (point) end debugp)))) 347 348(defun gds-eval-last-sexp (&optional debugp) 349 "Evaluate the sexp before point. If invoked with `C-u' prefix (or, 350in a program, with optional DEBUGP arg non-nil), pause and pop up the 351stack at the start of the evaluation, so that the user can single-step 352through the code." 353 (interactive "P") 354 (gds-eval-region (save-excursion (backward-sexp) (point)) (point) debugp)) 355 356;;;; Help. 357 358;; Help is implemented as a special case of evaluation, identified by 359;; the evaluation correlator 'help. 360 361(defun gds-help-symbol (sym) 362 "Get help for SYM (a Scheme symbol)." 363 (interactive 364 (let ((sym (thing-at-point 'symbol)) 365 (enable-recursive-minibuffers t) 366 val) 367 (setq val (read-from-minibuffer 368 (if sym 369 (format "Describe Guile symbol (default %s): " sym) 370 "Describe Guile symbol: "))) 371 (list (if (zerop (length val)) sym val)))) 372 (gds-eval-expression (format "(help %s)" sym) 'help)) 373 374(defun gds-apropos (regex) 375 "List Guile symbols matching REGEX." 376 (interactive 377 (let ((sym (thing-at-point 'symbol)) 378 (enable-recursive-minibuffers t) 379 val) 380 (setq val (read-from-minibuffer 381 (if sym 382 (format "Guile apropos (regexp, default \"%s\"): " sym) 383 "Guile apropos (regexp): "))) 384 (list (if (zerop (length val)) sym val)))) 385 (set-text-properties 0 (length regex) nil regex) 386 (gds-eval-expression (format "(apropos %S)" regex) 'apropos)) 387 388;;;; Displaying results of help and eval. 389 390(defun gds-display-results (client correlator stack-available results) 391 (let* ((helpp+bufname (cond ((eq (car correlator) 'help) 392 '(t . "*Guile Help*")) 393 ((eq (car correlator) 'apropos) 394 '(t . "*Guile Apropos*")) 395 (t 396 '(nil . "*Guile Evaluation*")))) 397 (helpp (car helpp+bufname))) 398 (let ((buf (get-buffer-create (cdr helpp+bufname)))) 399 (save-selected-window 400 (save-excursion 401 (set-buffer buf) 402 (gds-dissociate-buffer) 403 (erase-buffer) 404 (scheme-mode) 405 (insert (cdr correlator) "\n\n") 406 (while results 407 (insert (car results)) 408 (or (bolp) (insert "\\\n")) 409 (if helpp 410 nil 411 (if (cadr results) 412 (mapcar (function (lambda (value) 413 (insert " => " value "\n"))) 414 (cadr results)) 415 (insert " => no (or unspecified) value\n")) 416 (insert "\n")) 417 (setq results (cddr results))) 418 (if stack-available 419 (let ((beg (point)) 420 (map (make-sparse-keymap))) 421 (define-key map [mouse-1] 'gds-show-last-stack) 422 (define-key map "\C-m" 'gds-show-last-stack) 423 (insert "[click here to show error stack]") 424 (add-text-properties beg (point) 425 (list 'keymap map 426 'mouse-face 'highlight)) 427 (insert "\n"))) 428 (goto-char (point-min)) 429 (gds-associate-buffer client)) 430 (pop-to-buffer buf) 431 (run-hooks 'temp-buffer-show-hook))))) 432 433(defun gds-show-last-stack () 434 "Show stack of the most recent error." 435 (interactive) 436 (or gds-client 437 (gds-auto-associate-buffer) 438 (call-interactively 'gds-associate-buffer)) 439 (gds-send "debug-lazy-trap-context" gds-client)) 440 441;;;; Completion. 442 443(defvar gds-completion-results nil) 444 445(defun gds-complete-symbol () 446 "Complete the Guile symbol before point. Returns `t' if anything 447interesting happened, `nil' if not." 448 (interactive) 449 (or gds-client 450 (gds-auto-associate-buffer) 451 (call-interactively 'gds-associate-buffer)) 452 (let* ((chars (- (point) (save-excursion 453 (while (let ((syntax (char-syntax (char-before (point))))) 454 (or (eq syntax ?w) (eq syntax ?_))) 455 (forward-char -1)) 456 (point))))) 457 (if (zerop chars) 458 nil 459 (setq gds-completion-results nil) 460 (gds-send (format "complete %s" 461 (prin1-to-string 462 (buffer-substring-no-properties (- (point) chars) 463 (point)))) 464 gds-client) 465 (while (null gds-completion-results) 466 (accept-process-output gds-debug-server 0 200)) 467 (cond ((eq gds-completion-results 'error) 468 (error "Internal error - please report the contents of the *Guile Evaluation* window")) 469 ((eq gds-completion-results t) 470 nil) 471 ((stringp gds-completion-results) 472 (if (<= (length gds-completion-results) chars) 473 nil 474 (insert (substring gds-completion-results chars)) 475 (message "Sole completion") 476 t)) 477 ((= (length gds-completion-results) 1) 478 (if (<= (length (car gds-completion-results)) chars) 479 nil 480 (insert (substring (car gds-completion-results) chars)) 481 t)) 482 (t 483 (with-output-to-temp-buffer "*Completions*" 484 (display-completion-list gds-completion-results)) 485 t))))) 486 487;;;; Dispatcher for non-debug protocol. 488 489(defun gds-nondebug-protocol (client proc args) 490 (cond (;; (eval-results ...) - Results of evaluation. 491 (eq proc 'eval-results) 492 (gds-display-results client (car args) (cadr args) (cddr args)) 493 ;; If these results indicate an error, set 494 ;; gds-completion-results to non-nil in case the error arose 495 ;; when trying to do a completion. 496 (if (eq (caar args) 'error) 497 (setq gds-completion-results 'error))) 498 499 (;; (completion-result ...) - Available completions. 500 (eq proc 'completion-result) 501 (setq gds-completion-results (or (car args) t))) 502 503 (;; (note ...) - For debugging only. 504 (eq proc 'note)) 505 506 (;; (trace ...) - Tracing. 507 (eq proc 'trace) 508 (with-current-buffer (get-buffer-create "*GDS Trace*") 509 (save-excursion 510 (goto-char (point-max)) 511 (or (bolp) (insert "\n")) 512 (insert "[client " (number-to-string client) "] " (car args) "\n")))) 513 514 (t 515 ;; Unexpected. 516 (error "Bad protocol: %S" form)))) 517 518;;;; Scheme mode keymap items. 519 520(define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun) 521(define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp) 522(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression) 523(define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region) 524(define-key scheme-mode-map "\C-hg" 'gds-help-symbol) 525(define-key scheme-mode-map "\C-h\C-g" 'gds-apropos) 526(define-key scheme-mode-map "\C-hG" 'gds-apropos) 527(define-key scheme-mode-map "\C-hS" 'gds-show-last-stack) 528(define-key scheme-mode-map "\e\t" 'gds-complete-symbol) 529 530;;;; The end! 531 532(provide 'gds-scheme) 533 534;;; gds-scheme.el ends here. 535