#| -*-Scheme-*-

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

Copyright 1993,2001,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.

|#

;;;; Pseudo Shell subprocess in a buffer
;;; Inspired by "cmushell.el", by Olin Shivers.

(declare (usual-integrations))

(load-option 'DOSPROCESS)

(define-major-mode pseudo-shell fundamental "Pseudo Shell"
  "Major mode for executing DOS commands.
Return executes the current line as a DOS command.
Output is inserted into the buffer after the command.
There is currently no way to send input interactively to the command.
Use \\[shell-command-on-region] to feed input to the command.

cd, pushd, and popd commands are not executed as commands (they would have
no effect) but emulated directly by Edwin.

Customization: Entry to this mode runs the hook pseudo-shell-mode-hook."
  (lambda (buffer)
    (define-variable-local-value! buffer
      (ref-variable-object pseudo-shell-dirstack)
      '())
    (define-variable-local-value! buffer
      (ref-variable-object pseudo-shell-dirtrack?)
      true)
    (define-variable-local-value! buffer
      (ref-variable-object comint-input-ring)
      (make-ring (ref-variable comint-input-ring-size)))
    (define-variable-local-value! buffer
      (ref-variable-object comint-last-input-match)
      false)
    (define-variable-local-value! buffer
      (ref-variable-object pseudo-shell-active?)
      true)
    (event-distributor/invoke! (ref-variable pseudo-shell-mode-hook)
			       buffer)))

(define-variable pseudo-shell-mode-hook
  "An event distributor that is invoked when entering Pseudo Shell mode."
  (make-event-distributor))

(define-variable pseudo-shell-active?
  "Is this shell buffer active?"
  false
  boolean?)

(define-key 'pseudo-shell #\C-a 'pseudo-shell-bol)
(define-key 'pseudo-shell #\C-m 'pseudo-shell-execute-command)

(define-key 'pseudo-shell #\M-p 'comint-previous-input)
(define-key 'pseudo-shell #\M-n 'comint-next-input)
(define-key 'pseudo-shell '(#\C-c #\C-r) 'comint-history-search-backward)
(define-key 'pseudo-shell '(#\C-c #\C-s) 'comint-history-search-forward)
(define-key 'pseudo-shell '(#\C-c #\C-w) 'backward-kill-word)

;; (define-key 'pseudo-shell #\tab 'comint-dynamic-complete)
;; (define-key 'pseudo-shell #\M-? 'comint-dynamic-list-completions)

(define-command shell
  "Run an inferior pseudo shell, with I/O through buffer *shell*.
With prefix argument, unconditionally create a new buffer.
If buffer exists, just switch to buffer *shell*.

The buffer is put in Pseudo Shell mode, giving commands for sending input
and tracking directories."
  "P"
  (lambda (new-buffer?)
    (let ((buffer
	   (cond ((and (not new-buffer?)
		       (find-buffer "*shell*"))
		  => (lambda (buffer)
		       (let ((end (buffer-end buffer)))
			 (if (or (mark= end (line-start end 0))
				 (not (mark= end
					     (pseudo-shell-line-start end))))
			     (begin
			       (buffer-freshline buffer)
			       (insert-pseudo-shell-prompt!
				(buffer-end buffer)))))
		       buffer))
		 (else
		  (let ((buffer (create-buffer "*shell*")))
		    (insert-pseudo-shell-prompt! (buffer-start buffer))
		    (set-buffer-major-mode! buffer
					    (ref-mode-object pseudo-shell))
		    (set-buffer-default-directory!
		     buffer
		     (buffer-default-directory (current-buffer)))
		    buffer)))))

      (set-buffer-point! buffer (buffer-end buffer))
      (define-variable-local-value! buffer
	(ref-variable-object pseudo-shell-active?)
	true)
      (select-buffer buffer))))

(define (insert-pseudo-shell-prompt! #!optional point)
  ;; This corresponds to the $p$g prompt pattern.
  (insert-string (string-append
		  (pseudo-directory-namestring 
		   (buffer-default-directory (current-buffer)))
		  ">")
		 (if (default-object? point)
		     (current-point)
		     point)))

(define (pseudo-directory-namestring dir)
  (string-upcase
   (->namestring
    (directory-pathname-as-file dir))))

(define-command pseudo-shell-bol
  "Goes to the beginning of line, then skips past the prompt, if any.
With argument, don't skip the prompt -- go straight to column 0."
  "P"
  (lambda (argument)
    (set-current-point!
     (if argument
	 (line-start (current-point) 0)
	 (pseudo-shell-line-start (current-point))))))

(define (pseudo-shell-line-start mark)
  (let ((start (line-start mark 0)))
    (let ((mark (search-forward ">" start (line-end start 0))))
      (if (and mark (mark<= mark (line-end start 0)))
	  mark
	  start))))

(define-command pseudo-shell-execute-command
  "Execute the command on the current line."
  ()
  (lambda ()
    (let ((point (current-point))
	  (buffer (current-buffer)))
      (let ((start (pseudo-shell-line-start point))
	    (end (line-end point 0)))
	(let ((command (extract-string start end)))
	  (ring-push! (ref-variable comint-input-ring)
		      command)
	  (if (not (mark= end (buffer-end buffer)))
	      (begin
		(buffer-freshline buffer)
		(insert-region (line-start start 0) end
			       (buffer-end buffer))))
	  (buffer-freshline buffer)
	  (dynamic-wind
	   (lambda ()
	     unspecific)
	   (lambda ()
	     (pseudo-execute command
			     (buffer-default-directory buffer)
			     (buffer-end buffer))
	     (insert-newline (buffer-end buffer)))
	   (lambda ()
	     (if (ref-variable pseudo-shell-active? buffer)
		 (begin
		   (buffer-freshline buffer)
		   (insert-pseudo-shell-prompt! (buffer-end buffer))
		   (set-buffer-point! buffer (buffer-end buffer)))))))))))

(define (buffer-freshline buffer)
  (let* ((end (buffer-end buffer))
	 (start (line-start end 0)))
    (if (not (mark= start end))
	(insert-newline end))))

(define (pseudo-execute command dir output-mark)
  (let* ((command (string-trim command))
	 (next (string-find-next-char-in-set command char-set:whitespace))
	 (prog (if (not next)
		   command
		   (substring command 0 next))))
    (let ((handler (assoc (string-downcase prog) pseudo-shell-builtins)))
      (if (not handler)
	  (shell-command false output-mark dir command)
	  ((cdr handler) prog
			 (if (not next)
			     ""
			     (string-trim-left
			      (substring command (1+ next)
					 (string-length command))))
			 dir
			 output-mark)))))

(define-variable pseudo-shell-dirstack
  "List of directories saved by pushd in this buffer's shell."
  '())

(define-variable pseudo-shell-dirtrack? "" false)

(define (pseudo-parse-directory dir prog args)
  (cond ((string-null? args)
	 false)
	((string-find-next-char-in-set args char-set:whitespace)
	 (pseudo-error "Too many arguments" prog args))
	(else
	 (let ((dir (merge-pathnames args dir)))
	   (if (not (file-directory? dir))
	       (pseudo-error "Not a directory" prog args))
	   (pathname-simplify (pathname-as-directory dir))))))

(define (pseudo-error string . strings)
  (apply editor-error string
	 (map (lambda (string)
		(string-append " " string))
	      strings)))

(define pseudo-shell-builtins
  (let ((cd (lambda (prog args dir output-mark)
	      (if (not (ref-variable pseudo-shell-dirtrack?))
		  (editor-error "Not tracking directories"))
	      (let ((dir
		     (or (pseudo-parse-directory dir prog args)
			 (let ((home (get-environment-variable "HOME")))
			   (if (not home)
			       (pseudo-error "Unknown home:" prog)
			       (pathname-simplify
				(pathname-as-directory
				 (merge-pathnames home dir))))))))
		(set-default-directory dir)
		(insert-string
		 (string-append (pseudo-directory-namestring dir)
				"\n")
		 output-mark))))

	(show-dirs
	 (lambda (dir output-mark)
	   (with-output-to-mark output-mark
	     (lambda ()
	       (write-char #\()
	       (write-string (pseudo-directory-namestring dir))
	       (let loop ((dirs (ref-variable pseudo-shell-dirstack)))
		 (if (null? dirs)
		     (begin
		       (write-char #\))
		       (write-char #\Newline))
		     (begin
		       (write-char #\Space)
		       (write-string (pseudo-directory-namestring (car dirs)))
		       (loop (cdr dirs))))))))))

    `((""
       . ,(lambda (prog args dir output-mark)
	    prog args dir output-mark	; ignored
	    (message "Empty command line")
	    (editor-beep)))

      ("cd" . ,cd)

      ("pushd"
       . ,(lambda (prog args dir output-mark)
	    (if (not (ref-variable pseudo-shell-dirtrack?))
		(editor-error "Not tracking directories"))
	    (let ((dir* (pseudo-parse-directory dir prog args))
		  (stack (ref-variable pseudo-shell-dirstack)))
	      (cond (dir*
		     (set-variable! pseudo-shell-dirstack (cons dir stack))
		     (set-default-directory dir*)
		     (show-dirs dir* output-mark))
		    ((null? stack)
		     (pseudo-error "Empty directory stack:" prog))
		    (else
		     (let ((dir* (car stack)))
		       (set-variable! pseudo-shell-dirstack
				      (cons dir (cdr stack)))
		       (set-default-directory dir*)
		       (show-dirs dir* output-mark)))))))

      ("popd"
       . ,(lambda (prog args dir output-mark)
	    dir				; ignored
	    (if (not (ref-variable pseudo-shell-dirtrack?))
		(editor-error "Not tracking directories"))
	    (if (not (string-null? args))
		(pseudo-error "Too many arguments:" prog)
		(let ((stack (ref-variable pseudo-shell-dirstack)))
		  (if (null? stack)
		      (pseudo-error "Directory stack is empty:" prog)
		      (let ((dir (car stack)))
			(set-variable! pseudo-shell-dirstack (cdr stack))
			(set-default-directory dir)
			(insert-string
			 (string-append (pseudo-directory-namestring dir)
					"\n")
			 output-mark)))))))

      ("dirs"
       . ,(lambda (prog args dir output-mark)
	    (if (not (ref-variable pseudo-shell-dirtrack?))
		(editor-error "Not tracking directories"))
	    (if (not (string-null? args))
		(pseudo-error "Too many arguments:" prog))
	    (show-dirs dir output-mark)))

      ("cwd" . ,cd)

      ("exit"
       . ,(lambda (prog args dir output-mark)
	    prog args dir		; ignored
	    (define-variable-local-value! (mark-buffer output-mark)
	      (ref-variable-object pseudo-shell-active?)
	      false)
	    (message "Pseudo exitted"))))))