;;; -*- Mode: LISP, EDITOR; Package: HEMLOCK -*-

(in-package :hemlock)


(defcommand "Insert ()" (count)
  "Insert a pair of parentheses ().  With positive argument, puts
   parentheses around the next COUNT Forms, or previous COUNT forms, if
   COUNT is negative.  The point is positioned after the open parenthesis."
  "Insert a pair of parentheses ()."
  ;; TODO Form navigation is broken, so this is broken too -- it is
  ;; possible to put parens around more forms than there are in current
  ;; expression.  It works by moving past as many forms as there is, and
  ;; then each delimiting paren also counts as a form.
  (let ((point (current-point)))
    (pre-command-parse-check point)
    (cond (count
	   (when (minusp count)
	     (form-offset point count)
	     (setq count (- count)))
	   (insert-character point #\()
	   (with-mark ((m point))
	     (unless (form-offset m count)
	       (editor-error "Could not find that many forms."))
	     (insert-character m #\))))
	  ;; The simple case with no prefix argument
	  (t
	   (insert-character point #\()
	   (insert-character point #\))
	   (mark-before point)))))


(defcommand "Move Over )" (p)
  "Move past the next close parenthesis, and start a new line.  Any
   indentation preceding the preceding the parenthesis is deleted, and the
   new line is indented.  If there is only whitespace preceding the close
   paren, the paren is moved to the end of the previous line. With prefix
   argument, this command moves past next closing paren and inserts space."
  "Move past the next close parenthesis, and start a new line."
  ;; TODO This is still not complete, because SCAN-CHAR finds the next
  ;; close-paren, but we need to find the next paren that closes current
  ;; expression.  This will have to be updated when form navigation is
  ;; fixed.
  (let ((point (current-point)))
    (pre-command-parse-check point)
    (with-mark ((m point :right-inserting))
      (cond ((scan-char m :lisp-syntax :close-paren)
	     (cond ((same-line-p point m)
		    (delete-horizontal-space m))
		   (t
		    (move-mark point m)
		    (reverse-find-attribute point :whitespace #'zerop)
		    (delete-region (region point m))))
	     (cond ((not p)
		    ;; Move to the previous line if current is empty
		    (when (zerop (mark-charpos m))
		      (delete-characters m -1))
		    (mark-after m)
		    (move-mark point m)
		    (indent-new-line-command 1))
		   (t
		    (mark-after m)
		    (move-mark point m)
		    (insert-character m #\space))))
	    (t 
	     (editor-error "Could not find closing paren."))))))


(defcommand "Down List" (p)
  "Move down a level in list structure.  With positive argument, moves down
   p levels.  With negative argument, moves down backward, but only one
   level."
  "Move down a level in list structure."
  (let ((point (current-point))
	(count (or p 1)))
    (pre-command-parse-check point)
    (with-mark ((m point))
      (cond ((plusp count)
	     (loop repeat count
                   do (unless (and (scan-char m :lisp-syntax :open-paren)
                                   (mark-after m))
                        (editor-error))))
	    (t
	     (unless (and (rev-scan-char m :lisp-syntax :close-paren)
			  (mark-before m))
	       (editor-error))))
      (move-mark point m))))


(defun indent-using-spaces (mark column)
  "Inserts some spaces at MARK so that it moves to COLUMN.  This assumes
   mark is at the beginning of a line."
  (insert-string mark (make-string column :initial-element #\space)))


;;; TODO: If this is true, it is possible to make Hemlock unusable by
;;; killing last buffer and selecting Echo Area as the new buffer.
(defhvar "Ask for New Buffer"
  "If true, user is prompted for new buffer after current buffer is
   deleted.  If false then previous buffer is selected automatically."
  :value nil)


(defcommand "Kill Buffer" (p &optional buffer-name)
  "Prompts for a buffer to delete.
  If the buffer is modified, then let the user save the file before doing so.
  When deleting the current buffer, prompts for a new buffer to select.  If
  a buffer other than the current one is deleted then any windows into it
  are deleted."
  "Delete buffer Buffer-Name, doing sensible things if the buffer is displayed
  or current."
  (declare (ignore p))
  (let ((buffer (if buffer-name
		    (getstring buffer-name *buffer-names*)
		    (prompt-for-buffer :prompt "Kill Buffer: "
				       :default (current-buffer)))))
    (unless buffer
      (editor-error "No buffer named ~S" buffer-name))
    (when (and (buffer-modified buffer)
               (prompt-for-y-or-n :prompt "Save it first? "))
      (save-file-command nil buffer))
    (if (eq buffer (current-buffer))
        (let* ((previous (or (previous-buffer)
                             (editor-error "Cannot kill last buffer.")))
               (new (if (value ask-for-new-buffer)
                        (prompt-for-buffer
                         :prompt "New Buffer: "
                         :default previous
                         :help "Buffer to change to after the current one is killed.")
                        previous)))
          (when (eq new buffer)
            (editor-error "You must select a different buffer."))
          (dolist (w (buffer-windows buffer))
            (setf (window-buffer w) new))
          (setf (current-buffer) new))
        (dolist (w (buffer-windows buffer))
          (delete-window w)))
    (delete-buffer buffer)))


(defun find-file-buffer (pathname)
  "Return a buffer assoicated with the file Pathname, reading the file into a
   new buffer if necessary.  The second value is T if we created a buffer, NIL
   otherwise.  If the file has already been read, we check to see if the file
   has been modified on disk since it was read, giving the user various
   recovery options."
  (let* ((pathname (pathname pathname))
	 (trial-pathname (or (probe-file pathname)
			     (merge-pathnames pathname (default-directory))))
	 (found (find trial-pathname (the list *buffer-list*)
		     :key #'buffer-pathname :test #'equal)))
    (cond ((not found)
           (if (and (null (pathname-name trial-pathname))
                    (null (pathname-type trial-pathname))
                    (pathname-directory trial-pathname))
               ;; This looks like a directory -- make dired buffer
               (dired-guts nil nil trial-pathname)

               (let* ((name (pathname-to-buffer-name trial-pathname))
                      (found (getstring name *buffer-names*))
                      (use (if found
                               (prompt-for-buffer
                                :prompt "Buffer to use: "
                                :help
                                "Buffer name in use; give another buffer name, or confirm to reuse."
                                :default found
                                :must-exist nil)
                               (make-buffer name)))
                      (buffer (if (stringp use) (make-buffer use) use)))
                 (when (and (buffer-modified buffer)
                            (prompt-for-y-or-n :prompt
                                               "Buffer is modified, save it? "))
                   (save-file-command () buffer))
                 (read-buffer-file pathname buffer)
                 (values buffer (stringp use)))))
	  ((check-disk-version-consistent pathname found)
	   (values found nil))
	  (t
	   (read-buffer-file pathname found)
	   (values found nil)))))