;;; patcher-util.el --- General utilities

;; Copyright (C) 2008, 2009, 2010 Didier Verna
;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007 Didier Verna

;; Author:        Didier Verna <didier@xemacs.org>
;; Maintainer:    Didier Verna <didier@xemacs.org>
;; Created:       Sat Feb 13 14:31:32 2010
;; Last Revision: Fri Dec  2 22:06:27 2011
;; Keywords:      maint


;; This file is part of Patcher.

;; Patcher is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License version 3,
;; as published by the Free Software Foundation.

;; Patcher 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., 675 Mass Ave, Cambridge, MA 02139, USA.


;;; Commentary:

;; Contents management by FCM version 0.1.


;;; Code:

(require 'cl)

(eval-when-compile (require 'patcher-cutil))



;; ===========================================================================
;; 21.4 Backward compatibility
;; ===========================================================================

;; Byte compilation warnings =================================================

(unless (fboundp 'with-fboundp)
  (defmacro* with-fboundp (functions &body body)
    `(progn ,@body)))

(unless (fboundp 'with-boundp)
  (defmacro* with-boundp (variables &body body)
    `(progn ,@body)))

(unless (fboundp 'declare-fboundp)
  (defmacro declare-fboundp (form)
    `(progn ,form)))

(unless (fboundp 'declare-boundp)
  (defmacro declare-boundp (form)
    `(progn ,form)))

(unless (fboundp 'globally-declare-boundp)
  (defmacro globally-declare-boundp (variables)
    (setq variables (eval variables))
    (if (not (consp variables))
	(setq variables (list variables)))
    `(progn
      ,@(mapcar #'(lambda (sym) `(defvar ,sym)) variables))))




;; ===========================================================================
;; General utilities
;; ===========================================================================

(defun patcher-symbol (symbol)
  ;; Return SYMBOL prefixed with `patcher-'.
  (intern (concat "patcher-" (symbol-name symbol))))

(defmacro patcher-endpush (value location)
  ;; Like PUSH, but at the end.
  `(setf ,location (nconc ,location (list ,value))))

;; Hacked from read-number.
(defun* patcher-read-natnum
    (prompt &optional default-value (min 1)
	    &aux (pred (lambda (val) (and (integerp val) (>= val min))))
		 num)
  ;; Read a natural number from the minibuffer, prompting with PROMPT.
  ;; If optional second argument DEFAULT-VALUE is non-nil, return that if user
  ;; enters an empty line.
  ;; MIN (1 by default) specifies the lowest permissible value.
  (while (not (funcall pred num))
    (setq num (condition-case ()
		  (let ((minibuffer-completion-table nil))
		    (read-from-minibuffer
		     prompt (if num (prin1-to-string num)) nil t
		     nil nil (when default-value
			       (prin1-to-string default-value))))
		(input-error nil)
		(invalid-read-syntax nil)
		(end-of-file nil)))
    (or (funcall pred num) (beep)))
  num)

;; Hacked from y-or-n-p-minibuf. Isn't there something to do this already ??
(defun patcher-read-char (prompt chars)
  ;; PROMPT for one character from CHARS in the minibuffer.
  (save-excursion
    (let* ((pre "")
	   (answer (concat "(" chars ") "))
	   event)
      (while (stringp answer)
	(if (let ((cursor-in-echo-area t)
		  (inhibit-quit t))
	      (message "%s%s%s" pre prompt answer)
	      (setq event (next-command-event event))
	      (condition-case nil
		  (prog1
		      (or quit-flag (eq 'keyboard-quit (key-binding event)))
		    (setq quit-flag nil))
		(wrong-type-argument t)))
	    (progn
	      (message "%s%s%s%s" pre prompt answer
		       (single-key-description event))
	      (setq quit-flag nil)
	      (signal 'quit '())))
	(let* ((keys (events-to-keys (vector event))))
	  (cond ((and (= (length keys) 1)
		      (find (string-to-char keys) chars))
		 (message "%s%s%s" prompt answer keys)
		 (setq answer (string-to-char keys)))
		((button-release-event-p event) ; ignore them
		 nil)
		(t
		 (message "%s%s%s%s" pre prompt answer
			  (single-key-description event))
		 (ding nil 'y-or-n-p)
		 (discard-input)
		 (when (= (length pre) 0)
		   (setq pre (format "Please answer one of %s.  " chars)))))))
      answer)))

(put 'patcher-list= 'lisp-indent-function 2)
(defun* patcher-list=
    (list1 list2
     &key (test #'eql)
     &aux spurious (missing (copy-list list2)) common)
  ;; Compare LIST1 to LIST2 using TEST to compare elements (EQL by default).
  ;; Return 4 values: whether the two lists contain exactly the same elements
  ;; (regardless of their order), the list of spurious elements in LIST1, the
  ;; list of missing elements in LIST1 and the list of common elements.
  (dolist (elt list1 (values (and (not spurious) (not missing))
			     spurious
			     missing
			     common))
    (if (member* elt list2 :test test)
	(progn
	  (push elt common)
	  (setq missing (delete* elt missing :count 1 :test test)))
      (patcher-endpush elt spurious))))

;; #### NOTE: this function is currently only used as a gross hack to make
;; hooks project-specific. Otherwise, we would need to refcount them in case
;; overlapping instances have hooks in common. However, it might turn out one
;; day that some hooks actually like having the patcher-project variable set,
;; I don't know.
(defun patcher-wrap-hook (project hook)
  ;; Return a lambda expression wrapping a call to HOOK.
  ;; The call is wrapped in a dynamic biding of patcher-project.
  `(lambda ()
    (let ((patcher-project ,project))
      (,hook))))




;; ===========================================================================
;; Messaging
;; ===========================================================================

(defun patcher-message (msg &rest args)
  ;; Print a message, letting XEmacs time to display it.  Also, handle command
  ;; substitution.
  (message (substitute-command-keys (apply #'format msg args)))
  (save-current-buffer
    ;; sit-for may change the current buffer and we don't want that.
    (sit-for 0)))

(defun patcher-warning (msg &rest args)
  ;; Like `patcher-message, but triggers a Patcher warning instead.
  (warn (substitute-command-keys (apply #'format msg args))))


(put 'patcher-with-progression 'lisp-indent-function 1)
(defmacro* patcher-with-progression (msg &body body)
  ;; Wrap BODY in "msg..." / "msg...done" messages.
  ;; Return the value of BODY execution.
  `(prog2
       (patcher-message (concat ,msg "... please wait."))
       (progn ,@body)
     (patcher-message (concat ,msg "... done."))))

(put 'patcher-with-message 'lisp-indent-function 1)
(defmacro* patcher-with-message (message &body body)
  ;; Display MESSAGE in a temporary buffer and execute BODY.
  ;; Command keys in MESSAGE are substituted first.
  (let ((msg (gensym "msg")))
    `(save-window-excursion
      (save-excursion
	(let ((,msg (substitute-command-keys ,message)))
	  (with-output-to-temp-buffer " *Patcher Message*"
	    (set-buffer " *Patcher Message*")
	    (insert ,msg)))
	,@body))))

(defun patcher-modal-message (message)
  ;; Display MESSAGE and wait for user acknowledgment.
  (patcher-with-message message
    (read-string "Type return to proceed.")))




;; ===========================================================================
;; Error management
;; ===========================================================================

(define-error 'patcher
  "Root of the Patcher error hierarchy.")

(put 'patcher-define-error 'lisp-indent-function 1)
(defun* patcher-define-error
    (error-symbol
     &optional docstring (super-error 'patcher super-error-given-p))
  ;; Define a new Patcher error named PATCHER-<ERROR-SYMBOL>.
  ;; Optionally provide a DOCSTRING.
  ;; Define the error as a sub-error of SUPER-ERROR (PATCHER by default).
  (when super-error-given-p
    (setq super-error (patcher-symbol super-error)))
  (define-error (patcher-symbol error-symbol) docstring super-error))

(defun patcher-error (error &rest data)
  ;; Signal patcher ERROR with DATA.
  ;; #### WARNING: temporary compatibility hack.
  (if (stringp error)
      (error (substitute-command-keys (apply #'format error data)))
    (apply #'error (patcher-symbol error) data)))

(put 'patcher-condition-case 'lisp-indent-function 2)
(defmacro* patcher-condition-case (var bodyform &rest handlers)
  ;; Like condition-case, but prefix condition names with patcher-.
  `(condition-case ,var ,bodyform
    ,@(mapcar (lambda (handler)
		(cons (patcher-symbol (car handler))
		      (cdr handler)))
	      handlers)))

(defun patcher-display-error-message (message)
  ;; Display MESSAGE, beep and wait for user acknowledgment.
  (patcher-with-message message
    (beep)
    (read-string "Type return to proceed.")))




;; ===========================================================================
;; Files and buffers
;; ===========================================================================

(defun* patcher-file-buffer
    (file &optional find
	  &aux (existing (get-file-buffer file))
	       (buffer (or existing
			   (when find
			     (find-file-noselect file)))))
  ;; Find a buffer visiting FILE.
  ;; Return 2 values: a buffer visiting FILE and a boolean indicating whether
  ;; FILE was already visited. If FILE is not visited, return nil unless FIND,
  ;; in which case force visiting.
  (values buffer existing))

(defun* patcher-file-relative-name (file &optional (dir default-directory))
  ;; Construct a filename from FILE relative to DIR.
  (file-relative-name (expand-file-name file (expand-file-name dir))
		      (expand-file-name dir)))

(defun patcher-files-string (files)
  ;; Convert FILES to a string of relative file names.
  (mapconcat #'patcher-file-relative-name files " "))

(defun patcher-buffers-string (buffers)
  ;; Convert BUFFERS file names to a string of relative file names.
  (patcher-files-string (mapcar #'buffer-file-name buffers)))

(defun patcher-sort-files (files)
  ;; Sort FILES by lexicographic order.
  (sort (copy-list files) #'string<))

(defun patcher-save-buffer (buffer &optional force)
  ;; Offer to save BUFFER, or FORCE saving.
  (when (and (buffer-modified-p buffer)
	     (not (buffer-base-buffer buffer))
	     (buffer-file-name buffer)
	     (or force
		 (save-window-excursion
		   (display-buffer buffer)
		   (y-or-n-p
		    (format "Save %s? "
			(patcher-file-relative-name
			 (buffer-file-name buffer)))))))
    (save-excursion
      (set-buffer buffer)
      (condition-case ()
	  (save-buffer)
	(error nil)))))

(defun patcher-save-buffers (buffers &optional force)
  ;; Offer to save some BUFFERS, or FORCE saving.
  (dolist (buffer buffers)
    (patcher-save-buffer buffer force)))




;; ===========================================================================
;; Extents
;; ===========================================================================

;; #### WARNING: dynamic scoping fuckage at places. MAPCAR-EXTENTS uses some
;; PROPERTY and VALUE arguments so I need other names in BODIES and
;; PREDICATES.

(put 'patcher-mapcar-extents 'lisp-indent-function 1)
(defmacro* patcher-mapcar-extents
    ((extent property &key predicate here value) &body body)
  ;; Map BODY over all extents having patcher-PROPERTY in HERE.
  ;; Bind EXTENT to every extent in turn.
  ;; Optionally restrict patcher-PROPERTY to have VALUE.
  ;; If HERE is a buffer and narrowing is in effect, restrict to the narrowed
  ;; region.
  `(mapcar-extents (lambda (,extent) ,@body)
    ,predicate
    ,here
    (and (or (null ,here) (bufferp ,here))
     (point-min ,here))
    (and (or (null ,here) (bufferp ,here))
     (point-max ,here))
    nil (patcher-symbol ,property) ,value))

(defun patcher-collect-extents-property (property &optional here)
  ;; Collect the values of patcher-PROPERTY from all extents in HERE.
  (let ((dynamic-scoping-sucks-bones (patcher-symbol property)))
    (patcher-mapcar-extents (extent property :here here)
      (extent-property extent dynamic-scoping-sucks-bones))))

(put 'patcher-extents 'lisp-indent-function 1)
(defun* patcher-extents (property &key value (test #'eq) here)
  ;; Get all extents having patcher-PROPERTY equal to VALUE by TEST in HERE.
  (if (eq test #'eq)
      (mapcar-extents #'identity
	nil here nil nil nil (patcher-symbol property) value)
    (let ((dynamic-scoping-sucks-bones (patcher-symbol property))
	  (dynamic-scoping-sucks-bones-big-time value))
      (mapcar-extents #'identity
	(lambda (extent)
	  (funcall test
		   (extent-property extent dynamic-scoping-sucks-bones)
		   dynamic-scoping-sucks-bones-big-time))
	here))))

(put 'patcher-extent 'lisp-indent-function 1)
(defun* patcher-extent (property &key value (test #'eq) here)
  ;; Get the first extent having patcher-PROPERTY equal to VALUE by TEST in
  ;; HERE.
  (car (patcher-extents property :value value :test test :here here)))

(defun patcher-delete-extent (extent)
  ;; Delete EXTENT.
  ;; Return t an extent has actually been deleted.
  (when extent
    (delete-extent extent)
    t))

(defun patcher-delete-extent-and-region (extent)
  ;; Delete EXTENT and the corresponding region.
  ;; Return t an extent has actually been deleted.
  (when extent
    (delete-region (extent-start-position extent) (extent-end-position extent)
		   (extent-object extent))
    (delete-extent extent)
    t))

(put 'patcher-within-extent 'lisp-indent-function 1)
(defmacro* patcher-within-extent ((extent property) &body body)
  ;; Find an extent having the patcher-PROPERTY set, execute BODY in it.
  ;; EXTENT is bound to the extent when BODY is executed.
  ;; Start-close EXTENT around BODY so that insertion is possible.
  `(let ((,extent (patcher-extent ,property)))
    (when ,extent
      (save-excursion
	(goto-char (extent-start-position ,extent))
	(set-extent-property ,extent 'start-open nil)
	,@body
	(set-extent-property ,extent 'start-open t)))))




;; ===========================================================================
;; Processes
;; ===========================================================================

(patcher-define-error 'process
  "Patcher process error.")

(defun* patcher-call-process
    (command &optional (progression (format "Running `%s'" command))
		       ignore-exit-status)
  ;; Call a shell process to execute COMMAND.
  ;; Make people wait with PROGRESSION message.
  ;; Process output goes to current buffer, before current point.
  ;; Return point delimiting the end of the process output.
  ;; Throw a PATCHER-PROCESS error for non-zero exit status.
  (patcher-with-progression progression
    (unless (or (zerop (funcall #'call-process shell-file-name
				nil t nil shell-command-switch command))
		ignore-exit-status)
      (patcher-error 'process command)))
  (point))


(provide 'patcher-util)

;;; patcher-util.el ends here