;;; iuscheme.el --- Scheme support, Indiana Univeristy style
;;; 
;;; by Chris Haynes <chaynes@indiana.edu>
;;;
;;; Bugs: comint support, return at end

(autoload 'scheme-mode "cmuscheme" "Major mode for Scheme." t)
(autoload 'run-scheme "cmuscheme" "Switch to interactive Scheme buffer." t)
(autoload 'run-alt-scheme "cmuscheme" 
  "Switch to interactive alternative Scheme buffer." t)

(setq auto-mode-alist (cons '("\\.ss$" . scheme-mode) auto-mode-alist))

(defvar alt-scheme-program-name "scheme"
  "Program invoked by the run-alt-scheme command.")

(defun run-alt-scheme (cmd)
  "Run an inferior Scheme process, input and output via buffer *scheme*.
If there is a process already running in *scheme*, just switch to that buffer.
With argument, allows you to edit the command line (default is value
of alt-scheme-program-name).  Runs the hooks from inferior-scheme-mode-hook
and alt-scheme-hook \(after the comint-mode-hook is run).
\(Type \\[describe-mode] in the process buffer for a list of commands.)"

  (interactive (list (if current-prefix-arg
			 (read-string "Run Scheme: " alt-scheme-program-name)
			 alt-scheme-program-name)))
  (require 'cmuscheme)
  (if (not (comint-check-proc "*scheme*"))
      (let ((cmdlist (scheme-args-to-list cmd)))
	(set-buffer (apply 'make-comint "scheme" (car cmdlist)
			   nil (cdr cmdlist)))
	(inferior-scheme-mode)))
  (setq scheme-buffer "*scheme*")
  (run-hooks 'alt-scheme-hook)
  (switch-to-buffer "*scheme*"))

(add-hook 'scheme-mode-hook
	  '(lambda ()
	     (define-key scheme-mode-map "\C-c\t" 'scheme-indent-definition)
	     (define-key scheme-mode-map "\r" 'newline-and-indent)
	     (define-key scheme-mode-map "\C-h" 'help-command)))

(add-hook 'inferior-scheme-mode-hook
	  '(lambda ()
	     (make-local-variable 'last-input-start)
	     (setq last-input-start (make-marker))
	     (make-local-variable 'last-input-end)
	     (setq last-input-end (make-marker))
	     (define-key inferior-scheme-mode-map "\C-h" 'help-command)
	     (define-key inferior-scheme-mode-map "\n" 'newline-and-indent)
	     (define-key inferior-scheme-mode-map "\r" 'scheme-send-input)))

(defun scheme-indent-definition ()
  "Fix indentation of the current definition."
  (interactive)
  (save-excursion
    (end-of-defun)
    (scheme-indent-sexp)))

(defun scheme-send-input ()
  "Return sends the s-expression ending on the current line as input
to Scheme, unless the last s-expression is after the last text sent to
Scheme, but isn't everything after the last text sent, in which case just
indent the line.  If the current line is not the last line of the buffer, 
the s-expression is copied to the end first."
  (interactive)
  (let* ((process (get-buffer-process (current-buffer)))
	 (pmark (process-mark process))
	 (send-it t))
    (end-of-line)
    (if (eobp)
	(progn
	  (insert ?\n)
	  (save-excursion
	    (backward-sexp 1)
	    (re-search-backward "[^ \\t]")    
	    (forward-char 1)
	    (if (> (point) pmark) (setq send-it nil)))
	  (move-marker last-input-start pmark)
	  (move-marker last-input-end (point)))
      (backward-sexp)
      (let ((copy (buffer-substring (point) (progn (forward-sexp) (point)))))
	(goto-char (point-max))
	(move-marker last-input-start (point))
	(insert copy ?\n)
	(move-marker last-input-end (point))))
    (if send-it
	(progn
	  (send-region process last-input-start last-input-end)
	  (set-marker pmark (point))))
    (scheme-indent-line)))

(defun infer ()
  "Set up Infer as alt-scheme."
  (interactive)
  (setq auto-mode-alist (append '(("\\.is$" . scheme-mode)) auto-mode-alist))
  (setq alt-scheme-program-name "/nfs/moose/u/ftp/pub/chaynes/infer/infer")
  (setq alt-scheme-hook '(lambda () (setq comint-prompt-regexp "^|- *"))))

(defun calculate-scheme-indent (&optional parse-start)
  "Return appropriate indentation for current line as scheme code.
In usual case returns an integer: the column to indent to.
Can instead return a list, whose car is the column to indent to.
This means that following lines at the same level of indentation
should not necessarily be indented the same way.
The second element of the list is the buffer position
of the start of the containing expression."
  (save-excursion
    (beginning-of-line)
    (let ((indent-point (point)) (state '(0)) paren-depth desired-indent 
	  (retry t) last-sexp containing-sexp)
      (if parse-start
	  (goto-char parse-start)
	(beginning-of-defun))
      ;; Find outermost containing sexp
      (while (< (point) indent-point)
	(setq state (parse-partial-sexp (point) indent-point 0)))
      ;; Find innermost containing sexp
      (while (and retry (setq paren-depth (car state)) (> paren-depth 0))
	(setq retry nil)
	(setq last-sexp (nth 2 state))
	(setq containing-sexp (car (cdr state)))
	;; Position following last unclosed open.
	(goto-char (1+ containing-sexp))
	;; Is there a complete sexp since then?
	(if (and last-sexp (> last-sexp (point)))
	    ;; Yes, but is there a containing sexp after that?
	    (let ((peek (parse-partial-sexp last-sexp indent-point 0)))
	      (if (setq retry (car (cdr peek))) (setq state peek))))
	(if (not retry)
	    ;; Innermost containing sexp found
	    (progn 
	      (goto-char (1+ containing-sexp))
	      (if (not last-sexp)
		  ;; indent-point immediately follows open paren.
		  ;; Don't call hook.
		  (setq desired-indent (current-column))
		;; Move to first sexp after containing open paren
		(parse-partial-sexp (point) last-sexp 0 t)
		(cond
		 ((looking-at "\\s(")
		  ;; Looking at a list.  Don't call hook.
		  (if (not (> (save-excursion (forward-line 1) (point)) 
			      last-sexp))
		      (progn (goto-char last-sexp)
			     (beginning-of-line)
			     (parse-partial-sexp (point) last-sexp 0 t)))
		  ;; Indent under the list or under the first sexp on the
		  ;; same line as last-sexp.  Note that first thing on that
		  ;; line has to be complete sexp since we are inside the
		  ;; innermost containing sexp.
		  (backward-prefix-chars)
		  (setq desired-indent (current-column)))
		 ((save-excursion (forward-char -1) (looking-at "\\[")))
		  ;; Containing sexp is bracketed, so don't do anything
		  ;; now, which will give 2 space indent later.
		 ((> (save-excursion (forward-line 1) (point))
		     last-sexp)
		  ;; Last sexp is on same line as containing sexp.
		  ;; It's almost certainly a function call.
		  (parse-partial-sexp (point) last-sexp 0 t)
		  (if (and (/= (point) last-sexp) 
			   (> (+ scheme-max-indent (point)) last-sexp)
			   (not (scheme-indent-hookedp)))
		      (progn (forward-sexp 1)
			     (backward-prefix-chars)
			     (setq desired-point (current-column)))
		    (backward-prefix-chars)))
                 (t
		  ;; Indent beneath first sexp on same line as last-sexp.
		  ;; Again, it's almost certainly a function call.
		  (goto-char last-sexp)
		  (beginning-of-line)
		  (parse-partial-sexp (point) last-sexp 0 t)
		  (backward-prefix-chars)
		  (setq desired-indent (current-column))))))))
      ;; Point is at the point to indent under unless we are inside a string.
      ;; Call indentation hook except when overriden by scheme-indent-offset
      ;; or if the desired indentation has already been computed.
      (cond ((= paren-depth 0) (setq desired-indent (current-column)))
	    ((car (nthcdr 3 state))
	     ;; Inside a string, don't change indentation.
	     (goto-char indent-point)
	     (skip-chars-forward " \t")
	     (setq desired-indent (current-column)))
	    ((and (integerp scheme-indent-offset) containing-sexp)
	     ;; Indent by constant offset
	     (goto-char containing-sexp)
	     (setq desired-indent (+ scheme-indent-offset (current-column))))
	    ((not desired-indent)
	     ;; Use default indentation if not computed yet
	     (setq desired-indent (+ (- scheme-standard-indent 1)
				     (current-column)))))
      desired-indent)))

(defun scheme-indent-hookedp ()
  "True if point is at beginnning of special form with 
   scheme-indent-hook property."
  (save-excursion
    (let ((name (buffer-substring (point);(progn (forward-char -1) (point))
				  (progn (forward-sexp 1) (point)))))
      (get (intern-soft (downcase name)) 'scheme-indent-hook))))

(put 'with 'scheme-indent-hook t)
(put 'when 'scheme-indent-hook t)
(put 'set! 'scheme-indent-hook t)
(put 'let 'scheme-indent-hook t)
(put 'let* 'scheme-indent-hook t)
(put 'recur 'scheme-indent-hook t)
(put 'case 'scheme-indent-hook t)
(put 'rec 'scheme-indent-hook t)
(put 'variant-case 'scheme-indent-hook t)

(defvar scheme-max-indent 2 "*Maximum additional indentation for scheme-mode")
(defvar scheme-standard-indent 2 "*Standard indentation for scheme-mode")

(provide 'iuscheme)