#| -*-Scheme-*-

$Id: replaz.scm,v 1.83 2003/02/14 18:28:13 cph Exp $

Copyright 1986, 1989-1999 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.

|#

;;;; Replacement Commands

(declare (usual-integrations))

(define-variable case-replace
  "If true, means replacement commands should preserve case."
  true
  boolean?)

(define (replace-string-arguments name)
  (let ((source (prompt-for-string name #f)))
    (list source
	  (prompt-for-string (string-append name " " source " with")
			     #f
			     'DEFAULT-TYPE 'NULL-DEFAULT)
	  (command-argument))))

(define-command replace-string
  "Replace occurrences of FROM-STRING with TO-STRING.
Preserve case in each match if  case-replace  and  case-fold-search
are true and FROM-STRING has no uppercase letters.
Third arg DELIMITED (prefix arg if interactive) true means replace
only matches surrounded by word boundaries."
  (lambda () (replace-string-arguments "Replace string"))
  (lambda (from-string to-string delimited)
    (replace-string from-string to-string delimited false false)
    (message "Done")))

(define-command replace-regexp
  "Replace things after point matching REGEXP with TO-STRING.
Preserve case in each match if case-replace and case-fold-search
are true and REGEXP has no uppercase letters.
Third arg DELIMITED (prefix arg if interactive) true means replace
only matches surrounded by word boundaries.
In TO-STRING, \\& means insert what matched REGEXP,
and \\<n> means insert what matched <n>th \\(...\\) in REGEXP."
  (lambda () (replace-string-arguments "Replace regexp"))
  (lambda (regexp to-string delimited)
    (replace-string regexp to-string delimited false true)
    (message "Done")))

(define-command query-replace
  "Replace some occurrences of FROM-STRING with TO-STRING.
As each match is found, the user must type a character saying
what to do with it.  For directions, type \\[help-command] at that time.

Preserve case in each replacement if  case-replace  and  case-fold-search
are true and FROM-STRING has no uppercase letters.
Third arg DELIMITED (prefix arg if interactive) true means replace
only matches surrounded by word boundaries."
  (lambda () (replace-string-arguments "Query replace"))
  (lambda (from-string to-string delimited)
    (replace-string from-string to-string delimited true false)
    (message "Done")))

(define-command query-replace-regexp
  "Replace some things after point matching REGEXP with TO-STRING.
As each match is found, the user must type a character saying
what to do with it.  For directions, type \\[help-command] at that time.

Preserve case in each replacement if  case-replace  and  case-fold-search
are true and REGEXP has no uppercase letters.
Third arg DELIMITED (prefix arg if interactive) true means replace
only matches surrounded by word boundaries.
In TO-STRING, \\& means insert what matched REGEXP,
and \\<n> means insert what matched <n>th \\(...\\) in REGEXP."
  (lambda () (replace-string-arguments "Query replace regexp"))
  (lambda (regexp to-string delimited)
    (replace-string regexp to-string delimited true true)
    (message "Done")))

(define (replace-string source target delimited? query? regexp?)
  ;; Returns TRUE iff the query loop was exited at the user's request,
  ;; FALSE iff the loop finished by failing to find an occurrence.
  (let ((preserve-case?
	 (and (ref-variable case-replace)
	      (ref-variable case-fold-search)
	      (string-lower-case? source)
	      (not (string-null? target))
	      (string-lower-case? target)))
	(source*
	 (if delimited?
	     (string-append "\\b"
			    (if regexp? source (re-quote-string source))
			    "\\b")
	     source))
	(message-string
	 (string-append "Query replacing " source " with " target)))

    (define (replacement-loop point)
      (undo-boundary! point)
      (let ((done
	     (lambda ()
	       (set-current-point! point)
	       (done false))))
	(cond ((not (find-next-occurrence point))
	       (done))
	      ((mark< point (re-match-end 0))
	       (replacement-loop (perform-replacement #f)))
	      ((not (group-end? point))
	       (replacement-loop (mark1+ point)))
	      (else
	       (done)))))

    (define (query-loop point)
      (undo-boundary! point)
      (cond ((not (find-next-occurrence point))
	     (done false))
	    ((mark< point (re-match-end 0))
	     (set-current-mark! point)
	     (set-current-point! (re-match-end 0))
	     (perform-query false (re-match-data)))
	    ((not (group-end? point))
	     (query-loop (mark1+ point)))
	    (else
	     (done false))))

    (define (find-next-occurrence start)
      (if (or regexp? delimited?)
	  (re-search-forward source* start (group-end start))
	  (search-forward source* start (group-end start))))

    (define (perform-replacement match-data)
      (if match-data (set-re-match-data! match-data))
      (replace-match target preserve-case? (not regexp?)))

    (define (done value)
      (pop-current-mark!)
      value)

    (define (perform-query replaced? match-data)
      (message message-string ":")
      (let ((key (with-editor-interrupts-disabled keyboard-peek)))
	(let ((test-for
	       (lambda (key*)
		 (and (char? key)
		      (char=? key (remap-alias-key key*))
		      (begin
			(keyboard-read)
			true)))))
	  (cond ((test-for #\C-h)
		 (with-output-to-help-display
		  (lambda ()
		    (write-string message-string)
		    (write-string ".

Type space to replace one match, Rubout to skip to next,
Altmode to exit, Period to replace one match and exit,
Comma to replace but not move point immediately,
C-R to enter recursive edit, C-W to delete match and recursive edit,
! to replace all remaining matches with no more questions,
^ to move point back to previous match.")))
		 (perform-query replaced? match-data))
		((or (test-for #\altmode)
		     (test-for #\q))
		 (done true))
		((test-for #\^)
		 (set-current-point! (current-mark))
		 (perform-query true match-data))
		((or (test-for #\space)
		     (test-for #\y))
		 (if (not replaced?) (perform-replacement match-data))
		 (query-loop (current-point)))
		((test-for #\.)
		 (if (not replaced?) (perform-replacement match-data))
		 (done true))
		((test-for #\,)
		 (if (not replaced?) (perform-replacement match-data))
		 (perform-query true match-data))
		((test-for #\!)
		 (if (not replaced?) (perform-replacement match-data))
		 (replacement-loop (current-point)))
		((or (test-for #\rubout)
		     (test-for #\n))
		 (query-loop (current-point)))
		((test-for #\C-l)
		 ((ref-command recenter) false)
		 (perform-query replaced? match-data))
		((test-for #\C-r)
		 (edit)
		 (perform-query replaced? match-data))
		((test-for #\C-w)
		 (if (not replaced?) (delete-match))
		 (edit)
		 (perform-query true match-data))
		(else
		 (done true))))))

    (define (edit)
      (clear-message)
      (save-excursion enter-recursive-edit))

    (let ((point (current-point)))
      (push-current-mark! point)
      (push-current-mark! point)
      (if query?
	  (query-loop point)
	  (replacement-loop point)))))