guile18/emacs/gds-scheme.el

   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
  31 associate the current buffer with it, if there are no existing Guile
  32 clients available to GDS when the user does something that requires a
  33 running 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
  39 existing Guile client, if there is only only client known to GDS when
  40 the user does something that requires a running Guile client, and the
  41 current 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
  47 Guile client that most recently caused that buffer to be displayed,
  48 when the user does something that requires a running Guile client and
  49 the 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
  55 recently `touched' that buffer in the sense of using it to display
  56 source code, for example for the source code relevant to a debugger
  57 stack 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
  62 possible."
  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.
  89 This means that operations in this buffer that require a running Guile
  90 process - such as evaluation, help, completion and setting traps -
  91 will be sent to the Guile process whose name or connection number is
  92 CLIENT."
  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
 123 buffers."
 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
 135 from the GDS frontend in Emacs, because all of its threads are busy
 136 running 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
 143 frontend in Emacs, because at least one of its threads is waiting for
 144 GDS 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
 151 Emacs 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
 240 specified 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
 256 chunk of Scheme code (to be evaluated) comes.  GDS uses this prefix,
 257 followed by the buffer name, in two cases: when the buffer concerned
 258 is not associated with a file, or if the buffer has been modified
 259 since last saving to its file.  In the case where the buffer is
 260 identical 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.
 266 The name will be used by Guile as the port name when evaluating that
 267 region'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
 284 a program, with optional DEBUGP arg non-nil), pause and pop up the
 285 stack at the start of the evaluation, so that the user can single-step
 286 through 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'
 305 prefix (or, in a program, with optional DEBUGP arg non-nil), pause and
 306 pop up the stack at the start of the evaluation, so that the user can
 307 single-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),
 339 pause and pop up the stack at the start of the evaluation, so that the
 340 user 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,
 350 in a program, with optional DEBUGP arg non-nil), pause and pop up the
 351 stack at the start of the evaluation, so that the user can single-step
 352 through 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
 447 interesting 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.