;;; -*-Scheme-*-
;;;
;;; $Id: editor.scm,v 1.253 2001/12/19 05:25:25 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
;;;
;;; This program 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.
;;;
;;; This program 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 this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;;; 02111-1307, USA.

;;;; Editor Top Level

(declare (usual-integrations))

(define (edit . args)
  (call-with-current-continuation
   (lambda (continuation)
     (cond (within-editor?
	    (error "edwin: Editor already running"))
	   ((not edwin-editor)
	    (apply create-editor args))
	   ((not (null? args))
	    (error "edwin: Arguments ignored when re-entering editor" args))
	   (edwin-continuation
	    => (lambda (restart)
		 (set! edwin-continuation #f)
		 (within-continuation restart
		   (lambda ()
		     (set! editor-abort continuation)
		     unspecific)))))
     (fluid-let ((editor-abort continuation)
		 (current-editor edwin-editor)
		 (within-editor? #t)
		 (editor-thread (current-thread))
		 (editor-thread-root-continuation)
		 (editor-initial-threads '())
		 (inferior-thread-changes? #f)
		 (inferior-threads '())
		 (recursive-edit-continuation #f)
		 (recursive-edit-level 0))
       (editor-grab-display edwin-editor
	 (lambda (with-editor-ungrabbed operations)
	   (let ((message (cmdl-message/null)))
	     (cmdl/start
	      (make-cmdl
	       (nearest-cmdl)
	       dummy-i/o-port
	       (lambda (cmdl)
		 cmdl		;ignore
		 (bind-condition-handler (list condition-type:error)
		     internal-error-handler
		   (lambda ()
		     (call-with-current-continuation
		      (lambda (root-continuation)
			(set! editor-thread-root-continuation
			      root-continuation)
			(with-notification-output-port null-output-port
			  (lambda ()
			    (do ((thunks (let ((thunks editor-initial-threads))
					   (set! editor-initial-threads '())
					   thunks)
					 (cdr thunks)))
				((null? thunks))
			      (create-thread root-continuation (car thunks)))
			    (top-level-command-reader
			     edwin-initialization)))))))
		 message)
	       #f
	       `((START-CHILD ,(editor-start-child-cmdl with-editor-ungrabbed))
		 (CHILD-PORT ,(editor-child-cmdl-port (nearest-cmdl/port)))
		 ,@operations))
	      message))))))))

(define (edwin . args) (apply edit args))
(simple-command-line-parser "-edit" edit)

(define edwin-editor #f)
(define editor-abort)
(define current-editor)
(define within-editor? #f)
(define editor-thread)
(define editor-thread-root-continuation)
(define editor-initial-threads)
(define edwin-continuation)

;; Set this before entering the editor to get something done after the
;; editor's dynamic environment is initialized, but before the command
;; loop is started.
(define edwin-initialization #f)

(define (queue-initial-thread thunk)
  (set! editor-initial-threads (cons thunk editor-initial-threads))
  unspecific)

(define create-editor-args
  '())

(define (create-editor . args)
  (let ((args
	 (if (null? args)
	     create-editor-args
	     (begin
	       (set! create-editor-args args)
	       args))))
    (reset-editor)
    (event-distributor/invoke! editor-initializations)
    (set! edwin-editor
	  (make-editor "Edwin"
		       (let ((name (and (not (null? args)) (car args))))
			 (if name
			     (let ((type (name->display-type name)))
			       (if (not type)
				   (error "Unknown display type name:" name))
			       (if (not (display-type/available? type))
				   (error "Requested display type unavailable:"
					  type))
			       type)
			     (default-display-type '())))
		       (if (null? args) '() (cdr args))))
    (set! edwin-initialization
	  (lambda ()
	    (set! edwin-initialization #f)
	    (standard-editor-initialization)))
    (set! edwin-continuation #f)
    unspecific))

(define editor-initializations
  (make-event-distributor))

(define (default-display-type preferences)
  (define (fail)
    (error "Can't find any usable display type"))

  (define (find-any)
    (let ((types (editor-display-types)))
      (if (null? types)
	  (fail)
	  (car types))))

  (define (find-preferred display-type-names)
    (if (null? display-type-names)
	(find-any)
	(let ((next (name->display-type (car display-type-names))))
	  (if (and next 
		   (display-type/available? next))
	      next
	      (find-preferred (cdr display-type-names))))))

  (find-preferred preferences))

(define (standard-editor-initialization)
  (with-editor-interrupts-disabled
   (lambda ()
     (if (and (not init-file-loaded?)
	      (not inhibit-editor-init-file?))
	 (begin
	   (let ((filename (os/init-file-name)))
	     (if (file-exists? filename)
		 (load-edwin-file filename '(EDWIN) #t)))
	   (set! init-file-loaded? #t)
	   unspecific))))
  (let ((buffer (find-buffer initial-buffer-name)))
    (if (and buffer
	     (not inhibit-initial-inferior-repl?))
	(start-inferior-repl!
	 buffer
	 (nearest-repl/environment)
	 (and (not (ref-variable inhibit-startup-message))
	      (cmdl-message/append
	       (cmdl-message/active
		(lambda (port)
		  (identify-world port)
		  (newline port)))
	       (cmdl-message/strings
		"You are in an interaction window of the Edwin editor."
		"Type C-h for help.  C-h m will describe some commands.")))))))

(define inhibit-editor-init-file? #f)
(define init-file-loaded? #f)
(define inhibit-initial-inferior-repl? #f)

(define-variable inhibit-startup-message
  "True inhibits the initial startup messages.
This is for use in your personal init file, once you are familiar
with the contents of the startup message."
  #f
  boolean?)

(define (reset-editor)
  (without-interrupts
   (lambda ()
     (if edwin-editor
	 (begin
	   (for-each (lambda (screen)
		       (screen-discard! screen))
		     (editor-screens edwin-editor))
	   (set! edwin-editor #f)
	   (set! edwin-continuation)
	   (set! init-file-loaded? #f)
	   (weak-set-car! *previous-popped-up-window* #f)
	   (weak-set-car! *previous-popped-up-buffer* #f)
	   (weak-set-car! *minibuffer-scroll-window* #f)
	   unspecific)))))

(define (reset-editor-windows)
  (for-each (lambda (screen)
	      (send (screen-root-window screen) ':salvage!))
	    (editor-screens edwin-editor)))

(define (enter-recursive-edit)
  (let ((value
	 (call-with-current-continuation
	   (lambda (continuation)
	     (fluid-let ((recursive-edit-continuation continuation)
			 (recursive-edit-level (1+ recursive-edit-level)))
	       (let ((recursive-edit-event!
		      (lambda ()
			(for-each (lambda (window)
				    (window-modeline-event! window
							    'RECURSIVE-EDIT))
				  (window-list)))))
		 (dynamic-wind recursive-edit-event!
			       command-reader
			       recursive-edit-event!)))))))
    (if (eq? value 'ABORT)
	(abort-current-command)
	(begin
	  (reset-command-prompt!)
	  value))))

(define (exit-recursive-edit value)
  (if recursive-edit-continuation
      (recursive-edit-continuation value)
      (editor-error "No recursive edit is in progress")))

(define recursive-edit-continuation)
(define recursive-edit-level)

(define (editor-gc-daemon)
  (let ((editor edwin-editor))
    (if editor
	(do ((buffers (bufferset-buffer-list (editor-bufferset editor))
		      (cdr buffers)))
	    ((null? buffers))
	  (clean-group-marks! (buffer-group (car buffers)))))))

(add-gc-daemon!/no-restore editor-gc-daemon)
(add-event-receiver! event:after-restore editor-gc-daemon)

(define (internal-error-handler condition)
  (cond ((and (eq? condition-type:primitive-procedure-error
		   (condition/type condition))
	      (let ((operator (access-condition condition 'OPERATOR)))
		(or (eq? operator (ucode-primitive x-display-process-events 2))
		    (eq? operator (ucode-primitive x-display-flush 1)))))
	 ;; This error indicates that the connection to the X server
	 ;; has been broken.  The safest thing to do is to kill the
	 ;; editor.
	 (exit-editor))
	(debug-internal-errors?
	 (error condition))
	(else
	 (maybe-debug-scheme-error
	  (ref-variable-object debug-on-internal-error)
	  condition "internal")
	 (editor-beep)
	 (message (condition/report-string condition))
	 (return-to-command-loop condition))))

(define-variable debug-on-internal-error
  "True means enter debugger if error is signalled while the editor is running.
This does not affect editor errors or evaluation errors."
  #f
  boolean?)

(define debug-internal-errors? #f)

(define condition-type:editor-error
  (make-condition-type 'EDITOR-ERROR condition-type:error '(STRINGS)
    (lambda (condition port)
      (write-string "Editor error: " port)
      (write-string (message-args->string (editor-error-strings condition))
		    port))))

(define editor-error
  (let ((signaller
	 (condition-signaller condition-type:editor-error
			      '(STRINGS)
			      standard-error-handler)))
    (lambda strings
      (signaller strings))))

(define editor-error-strings
  (condition-accessor condition-type:editor-error 'STRINGS))

(define (editor-error-handler condition)
  (maybe-debug-scheme-error (ref-variable-object debug-on-editor-error)
			    condition "editor")
  (editor-beep)
  (let ((strings (editor-error-strings condition)))
    (if (not (null? strings))
	(apply message strings)))
  (return-to-command-loop condition))

(define-variable debug-on-editor-error
  "True means signal Scheme error when an editor error occurs."
  #f
  boolean?)

(define (standard-error-report condition error-type-name in-prompt?)
  (let ((report-string (condition/report-string condition)))
    (let ((typein-report
	   (lambda ()
	     (message (string-capitalize error-type-name)
		      " error: "
		      report-string)))
	  (error-buffer-report
	   (lambda ()
	     (string->temporary-buffer report-string "*error*"
				       '(SHRINK-WINDOW))
	     (message (string-capitalize error-type-name) " error")
	     (update-screens! #f)))
	  (transcript-report
	   (lambda ()
	     (and (ref-variable enable-transcript-buffer)
		  (begin
		    (with-output-to-transcript-buffer
		      (lambda ()
			(fresh-line)
			(write-string ";Error: ")
			(write-string report-string)
			(newline)
			(newline)))
		    #t)))))
      (let ((fit-report
	     (lambda ()
	       (if (and (not in-prompt?)
			(not (string-find-next-char report-string #\newline))
			(< (string-columns
			    report-string 0 8
			    (variable-default-value
			     (ref-variable-object char-image-strings)))
			   (window-x-size (typein-window))))
		   (typein-report)
		   (error-buffer-report)))))
	(case (ref-variable error-display-mode)
	  ((STANDARD) (transcript-report) (fit-report))
	  ((TRANSCRIPT) (or (transcript-report) (fit-report)))
	  ((ERROR-BUFFER) (error-buffer-report))
	  ((TYPEIN) (if in-prompt? (error-buffer-report) (typein-report)))
	  ((FIT) (fit-report)))))))

(define-variable error-display-mode
  "Value of this variable controls the way evaluation error messages
are displayed:
STANDARD      like FIT, except messages also appear in transcript buffer,
                if it is enabled.
FIT           messages appear in typein window if they fit;
                in *error* buffer if they don't.
TYPEIN        messages appear in typein window.
ERROR-BUFFER  messages appear in *error* buffer.
TRANSCRIPT    messages appear in transcript buffer, if it is enabled;
                otherwise this is the same as FIT."
  'STANDARD
  (lambda (value) (memq value '(STANDARD TRANSCRIPT ERROR-BUFFER TYPEIN FIT))))

(define condition-type:abort-current-command
  (make-condition-type 'ABORT-CURRENT-COMMAND #f '(INPUT)
    (lambda (condition port)
      (write-string "Abort current command" port)
      (let ((input (abort-current-command/input condition)))
	(if input
	    (begin
	      (write-string " with input: " port)
	      (write input port))))
      (write-string "." port))))

(define condition/abort-current-command?
  (condition-predicate condition-type:abort-current-command))

(define abort-current-command/input
  (condition-accessor condition-type:abort-current-command 'INPUT))

(define abort-current-command
  (let ((signaller
	 (condition-signaller condition-type:abort-current-command
			      '(INPUT)
			      standard-error-handler)))
    (lambda (#!optional input)
      (let ((input (if (default-object? input) #f input)))
	(if (not (or (not input) (input-event? input)))
	    (error:wrong-type-argument input "input event"
				       'ABORT-CURRENT-COMMAND))
	(signaller input)))))

(define-structure (input-event
		   (constructor make-input-event (type operator . operands))
		   (conc-name input-event/))
  (type #f read-only #t)
  (operator #f read-only #t)
  (operands #f read-only #t))

(define (apply-input-event input-event)
  (if (not (input-event? input-event))
      (error:wrong-type-argument input-event "input event" apply-input-event))
  (apply (input-event/operator input-event)
	 (input-event/operands input-event)))

(define condition-type:^G
  (make-condition-type '^G condition-type:abort-current-command '()
    (lambda (condition port)
      condition
      (write-string "Signal editor ^G." port))))

(define condition/^G?
  (condition-predicate condition-type:^G))

(define ^G-signal
  (let ((signaller
	 (condition-signaller condition-type:^G
			      '(INPUT)
			      standard-error-handler)))
    (lambda ()
      (signaller #f))))

(define (quit-editor-and-signal-error condition)
  (quit-editor-and (lambda () (error condition))))

(define (quit-editor)
  (quit-editor-and (lambda () *the-non-printing-object*)))

(define (quit-scheme)
  (let ((dir (buffer-default-directory (current-buffer))))
    (quit-editor-and (lambda () (os/quit dir) (edit)))))

(define (quit-editor-and thunk)
  (call-with-current-continuation
   (lambda (continuation)
     (within-continuation editor-abort
       (lambda ()
	 (set! edwin-continuation continuation)
	 (thunk))))))

(define (exit-editor)
  (within-continuation editor-abort reset-editor))

(define (exit-scheme)
  (within-continuation editor-abort %exit))

(define (unwind-protect setup body cleanup)
  (dynamic-wind (or setup (lambda () unspecific)) body cleanup))

(define (editor-grab-display editor receiver)
  (display-type/with-display-grabbed (editor-display-type editor)
    (lambda (with-display-ungrabbed operations)
      (with-current-local-bindings!
	(lambda ()
	  (let ((enter
		 (lambda ()
		   (let ((screen (selected-screen)))
		     (screen-enter! screen)
		     (update-screen! screen #t))))
		(exit
		 (lambda ()
		   (screen-exit! (selected-screen)))))
	    (dynamic-wind enter
			  (lambda ()
			    (receiver
			     (lambda (thunk)
			       (dynamic-wind exit
					     (lambda ()
					       (with-display-ungrabbed thunk))
					     enter))
			      operations))
			  exit)))))))

(define dummy-i/o-port
  (make-i/o-port
   (map (lambda (name)
	  (list name
		(lambda (port . ignore)
		  ignore
		  (error "Attempt to perform a"
			 name
			 (error-irritant/noise " operation on dummy I/O port:")
			 port))))
	'(CHAR-READY? READ-CHAR PEEK-CHAR WRITE-CHAR))
   #f))

(define null-output-port
  (make-output-port `((WRITE-CHAR ,(lambda (port char) port char unspecific)))
		    #f))

(define (editor-start-child-cmdl with-editor-ungrabbed)
  (lambda (cmdl thunk) cmdl (with-editor-ungrabbed thunk)))

(define (editor-child-cmdl-port port)
  (lambda (cmdl) cmdl port))

(define inferior-thread-changes?)
(define inferior-threads)

(define (register-inferior-thread! thread output-processor)
  (let ((flags (cons #f output-processor)))
    (without-interrupts
     (lambda ()
       (set! inferior-threads
	     (cons (weak-cons thread flags)
		   inferior-threads))
       unspecific))
    flags))

(define (deregister-inferior-thread! flags)
  (without-interrupts
   (lambda ()
     (let loop ((threads inferior-threads) (prev #f))
       (if (pair? threads)
	   (if (eq? flags (weak-cdr (car threads)))
	       (begin
		 (if prev
		     (set-cdr! prev (cdr threads))
		     (set! inferior-threads (cdr threads)))
		 (weak-set-car! (car threads) #f)
		 (weak-set-cdr! (car threads) #f))
	       (loop (cdr threads) threads)))))))

(define (start-standard-polling-thread interval output-processor)
  (let ((holder (list #f)))
    (set-car! holder
	      (register-inferior-thread!
	       (let ((thread
		      (create-thread editor-thread-root-continuation
			(lambda ()
			  (do () (#f)
			    (let ((registration (car holder)))
			      (cond ((eq? registration 'KILL-THREAD)
				     (exit-current-thread unspecific))
				    (registration
				     (inferior-thread-output! registration))))
			    (sleep-current-thread interval))))))
		 (detach-thread thread)
		 thread)
	       output-processor))
    holder))

(define (stop-standard-polling-thread holder)
  (without-interrupts
   (lambda ()
     (let ((registration (car holder)))
       (if (and registration (not (eq? registration 'KILL-THREAD)))
	   (deregister-inferior-thread! registration)))
     (set-car! holder 'KILL-THREAD))))

(define (inferior-thread-output! flags)
  (without-interrupts (lambda () (inferior-thread-output!/unsafe flags))))

(define-integrable (inferior-thread-output!/unsafe flags)
  (set-car! flags #t)
  (set! inferior-thread-changes? #t)
  (signal-thread-event editor-thread #f))

(define (accept-thread-output)
  (with-interrupt-mask interrupt-mask/gc-ok
    (lambda (interrupt-mask)
      (and inferior-thread-changes?
	   (begin
	     (set! inferior-thread-changes? #f)
	     (let loop ((threads inferior-threads) (prev #f) (output? #f))
	       (if (null? threads)
		   output?
		   (let ((record (car threads))
			 (next (cdr threads)))
		     (let ((thread (weak-car record))
			   (flags (weak-cdr record)))
		       (if (and thread (not (thread-dead? thread)))
			   (loop next
				 threads
				 (if (car flags)
				     (begin
				       (set-car! flags #f)
				       (let ((result
					      (invoke-thread-output-processor
					       (cdr flags)
					       interrupt-mask)))
					 (if (eq? output? 'FORCE-RETURN)
					     output?
					     (or result output?))))
				     output?))
			   (begin
			     (if prev
				 (set-cdr! prev next)
				 (set! inferior-threads next))
			     (loop next prev output?))))))))))))

(define (invoke-thread-output-processor processor interrupt-mask)
  (call-with-current-continuation
   (lambda (k)
     (with-restart 'ABORT "Return to ACCEPT-THREAD-OUTPUT."
	 (lambda () (k #t))
	 values
       (lambda ()
	 (with-interrupt-mask interrupt-mask
	   (lambda (interrupt-mask)
	     interrupt-mask
	     (processor))))))))