#| -*-Scheme-*-

$Id: bufcom.scm,v 1.110 2003/02/14 18:28:11 cph Exp $

Copyright 1986,1989,1990,1992,1994,1996 Massachusetts Institute of Technology
Copyright 1997,1998,1999,2000,2003 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme 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 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;;; Buffer Commands

(declare (usual-integrations))

(define (prompt-for-select-buffer prompt)
  (lambda ()
    (list
     (buffer-name
      (prompt-for-buffer prompt (previous-buffer))))))

(define-command switch-to-buffer
  "Select buffer with specified name.
If the variable select-buffer-create is true,
specifying a non-existent buffer will cause it to be created."
  (prompt-for-select-buffer "Switch to buffer")
  (lambda (buffer)
    (select-buffer (find-buffer buffer #t))))

(define-command switch-to-buffer-other-window
  "Select buffer in another window."
  (prompt-for-select-buffer "Switch to buffer in other window")
  (lambda (buffer)
    (select-buffer-other-window (find-buffer buffer #t))))

(define-command switch-to-buffer-other-frame
  "Select buffer in another frame."
  (prompt-for-select-buffer "Switch to buffer in other frame")
  (lambda (buffer)
    (select-buffer-other-screen (find-buffer buffer #t))))
(define edwin-command$switch-to-buffer-other-screen
  edwin-command$switch-to-buffer-other-frame)

(define-command create-buffer
  "Create a new buffer with a given name, and select it."
  "sCreate buffer"
  (lambda (name)
    (select-buffer (new-buffer name))))

(define-command create-buffer-other-frame
  "Create a new buffer with a given name, and select it in another frame."
  "sCreate buffer in other frame"
  (lambda (name)
    (select-buffer-other-screen (new-buffer name))))
(define edwin-command$create-buffer-other-screen
  edwin-command$create-buffer-other-frame)

(define-command insert-buffer
  "Insert the contents of a specified buffer at point."
  "bInsert buffer"
  (lambda (buffer)
    (let ((point (mark-right-inserting (current-point))))
      (region-insert-string!
       point
       (region->string (buffer-region (find-buffer buffer #t))))
      (push-current-mark! (current-point))
      (set-current-point! point))))

(define-command twiddle-buffers
  "Select previous buffer."
  ()
  (lambda ()
    (let ((buffer (previous-buffer)))
      (if buffer
	  (select-buffer buffer)
	  (editor-error "No previous buffer to select")))))

(define-command bury-buffer
  "Put current buffer at the end of the list of all buffers.
There it is the least likely candidate for other-buffer to return;
thus, the least likely buffer for \\[switch-to-buffer] to select by default."
  ()
  (lambda ()
    (let ((buffer (current-buffer))
	  (previous (previous-buffer)))
      (if previous
	  (begin
	    (select-buffer previous)
	    (bury-buffer buffer))))))

(define-command rename-buffer
  "Change the name of the current buffer.
Reads the new name in the echo area."
  "sRename buffer (to new name)"
  (lambda (name)
    (if (find-buffer name)
	(editor-error "Buffer named " name " already exists"))
    (rename-buffer (current-buffer) name)))

(define-command kill-buffer
  "One arg, a string or a buffer.  Get rid of the specified buffer."
  "bKill buffer"
  (lambda (buffer)
    (kill-buffer-interactive (find-buffer buffer #t))))

(define (kill-buffer-interactive buffer)
  (if (not (other-buffer buffer)) (editor-error "Only one buffer"))
  (save-buffer-changes buffer)
  (if (for-all? (ref-variable kill-buffer-query-procedures buffer)
	(lambda (procedure)
	  (procedure buffer)))
      (kill-buffer buffer)
      (message "Buffer not killed.")))

(define (kill-buffer-query-modified buffer)
  (or (not (and (buffer-pathname buffer)
		(buffer-modified? buffer)
		(buffer-writeable? buffer)))
      (prompt-for-yes-or-no?
       (string-append "Buffer "
		      (buffer-name buffer)
		      " modified; kill anyway"))))

(define (kill-buffer-query-process buffer)
  (or (not (get-buffer-process buffer))
      (prompt-for-yes-or-no?
       (string-append "Buffer "
		      (buffer-name buffer)
		      " has an active process; kill anyway"))))

(define-variable kill-buffer-query-procedures
  "List of procedures called to query before killing a buffer.
Each procedure is called with one argument, the buffer being killed.
If any procedure returns #f, the buffer is not killed."
  (list kill-buffer-query-modified kill-buffer-query-process)
  (lambda (object) (and (list? object) (for-all? object procedure?))))

(define-command kill-some-buffers
  "For each buffer, ask whether to kill it."
  ()
  (lambda ()
    (kill-some-buffers true)))

(define (kill-some-buffers prompt?)
  (for-each (lambda (buffer)
	      (if (and (not (minibuffer? buffer))
		       (or (not prompt?)
			   (prompt-for-confirmation?
			    (string-append "Kill buffer '"
					   (buffer-name buffer)
					   "'"))))
		  (if (other-buffer buffer)
		      (kill-buffer-interactive buffer)
		      (let ((dummy (new-buffer "*Dummy*")))
			(kill-buffer-interactive buffer)
			(create-buffer initial-buffer-name)
			(kill-buffer dummy)))))
	    (buffer-list)))

(define-command normal-mode
  "Choose the major mode for this buffer automatically.
Also sets up any specified local variables of the file.
Uses the visited file name, the -*- line, and the local variables spec."
  ()
  (lambda ()
    (normal-mode (current-buffer) false)))

(define-command toggle-mode-lock
  "Change whether this buffer has its major mode locked.
When locked, the buffer's major mode may not be changed."
  ()
  (lambda ()
    (let ((buffer (current-buffer)))
      (if (buffer-get buffer 'MAJOR-MODE-LOCKED)
	  (begin
	    (buffer-remove! buffer 'MAJOR-MODE-LOCKED)
	    (message "Major mode unlocked"))
	  (begin
	    (buffer-put! buffer 'MAJOR-MODE-LOCKED true)
	    (message "Major mode locked"))))))

(define-command not-modified
  "Pretend that this buffer hasn't been altered."
  ()
  (lambda ()
    (buffer-not-modified! (current-buffer))))

(define-command toggle-read-only
  "Change whether this buffer is visiting its file read-only."
  ()
  (lambda ()
    (let ((buffer (current-buffer)))
      (if (buffer-writeable? buffer)
	  (set-buffer-read-only! buffer)
	  (set-buffer-writeable! buffer)))))

(define-command no-toggle-read-only
  "Display warning indicating that this buffer may not be modified."
  ()
  (lambda ()
    (editor-failure "This buffer may not be modified.")))

(define (save-buffer-changes buffer)
  (if (and (buffer-pathname buffer)
	   (buffer-modified? buffer)
	   (buffer-writeable? buffer)
	   (prompt-for-yes-or-no?
	    (string-append "Buffer "
			   (buffer-name buffer)
			   " contains changes.  Write them out")))
      (write-buffer-interactive buffer false)))

(define (new-buffer name)
  (create-buffer (new-buffer-name name)))

(define (new-buffer-name name)
  (if (find-buffer name)
      (let search-loop ((n 2))
	(let ((new-name (string-append name "<" (write-to-string n) ">")))
	  (if (find-buffer new-name)
	      (search-loop (1+ n))
	      new-name)))
      name))

(define (pop-up-temporary-buffer name properties initialization)
  (let ((buffer (temporary-buffer name)))
    (let ((window (pop-up-buffer buffer #f)))
      (initialization buffer window)
      (set-buffer-point! buffer (buffer-start buffer))
      (buffer-not-modified! buffer)
      (if (memq 'READ-ONLY properties)
	  (set-buffer-read-only! buffer))
      (if (and window (memq 'SHRINK-WINDOW properties))
	  (shrink-window-if-larger-than-buffer window))
      (if (and (memq 'FLUSH-ON-SPACE properties)
	       (not (typein-window? (current-window))))
	  (begin
	    (message "Hit space to flush.")
	    (reset-command-prompt!)
	    (let ((char (keyboard-peek)))
	      (if (eqv? #\space char)
		  (begin
		    (keyboard-read)
		    (kill-pop-up-buffer #f))))
	    (clear-message))))))

(define (string->temporary-buffer string name properties)
  (pop-up-temporary-buffer name properties
    (lambda (buffer window)
      window
      (insert-string string (buffer-point buffer)))))

(define (call-with-output-to-temporary-buffer name properties procedure)
  (pop-up-temporary-buffer name properties
    (lambda (buffer window)
      window
      (call-with-output-mark (buffer-point buffer) procedure))))

(define (with-output-to-temporary-buffer name properties thunk)
  (call-with-output-to-temporary-buffer name properties
    (lambda (port)
      (with-output-to-port port thunk))))

(define (call-with-temporary-buffer name procedure)
  (let ((buffer))
    (dynamic-wind (lambda ()
		    (set! buffer (temporary-buffer name)))
		  (lambda ()
		    (procedure buffer))
		  (lambda ()
		    (kill-buffer buffer)
		    (set! buffer)
		    unspecific))))

(define (temporary-buffer name)
  (let ((buffer (find-or-create-buffer name)))
    (buffer-reset! buffer)
    buffer))

(define (prompt-for-buffer prompt default-buffer . options)
  (let ((name
	 (apply prompt-for-buffer-name prompt default-buffer
		'REQUIRE-MATCH? (not (ref-variable select-buffer-create))
		options)))
    (or (find-buffer name)
	(let loop ((hooks (ref-variable select-buffer-not-found-hooks)))
	  (cond ((null? hooks)
		 (let ((buffer (create-buffer name)))
		   (temporary-message "(New Buffer)")
		   buffer))
		((let ((result ((car hooks) name)))
		   (and (buffer? result)
			result)))
		(else
		 (loop (cdr hooks))))))))

(define-variable select-buffer-create
  "If true, buffer selection commands may create new buffers."
  true
  boolean?)

(define-variable select-buffer-not-found-hooks
  "List of procedures to be called for select-buffer on nonexistent buffer.
These procedures are called as soon as the error is detected.
The procedures are called in the order given,
until one of them returns a buffer.
This variable has no effect if select-buffer-create is false."
  '()
  list?)

(define (prompt-for-existing-buffer prompt default-buffer . options)
  (find-buffer (apply prompt-for-buffer-name prompt default-buffer
		      'REQUIRE-MATCH? #t
		      options)
	       #t))

(define (prompt-for-buffer-name prompt default-buffer . options)
  (apply prompt-for-string-table-name
	 prompt
	 (and default-buffer (buffer-name default-buffer))
	 (buffer-names)
	 'DEFAULT-TYPE (if default-buffer 'VISIBLE-DEFAULT 'NO-DEFAULT)
	 options))