;;; p4-widgets.el --- 

;; Author: Paul Du Bois <dubois@geoworks.com>
;; Maintainer: dubois@infinite-machine.com
;; $Id: //depot/tools/lisp/p4-widgets.el#1 $

;;; Commentary:

;; Code to widget-ify various p4.el modes, pulled out so people don't
;; have to load widget unless necessary.  This file contains no user
;; callable code.

;; Currently, only p4-job-mode supports widget-ifying.

;; The variable "p4-jm-pretty-name-alist" can be used to customize
;; the menu-tags of 'select' jobspec fields.

;;; Code:

(require 'wid-edit)
(require 'p4-job-mode)

;;; ----------------------------------------------------------------------
;;; Non-mode-specific widget utilities
;;; ----------------------------------------------------------------------

(defcustom p4-w-eat-newlines nil
  "If non-nil, p4 widgets will be squeezed together"
  :group 'p4
  :type 'boolean)

(defvar p4-jm-pretty-name-alist
  '(("request" . "feature request"))
  "* Alist of name -> pretty menu name mappings for widgets.
This should be customized per-site.")

(defun p4-widget-move-and-invoke (event)
  "Move to where you click, and if it is an active field, invoke it."
  (interactive "e")
  (mouse-set-point event)
  (if (widget-event-point event)
      (let* ((pos (widget-event-point event))
	     (button (get-char-property pos 'button)))
	(if button
	    (widget-button-click event)))))

(defun p4-w-find-and-kill (tag)
  ;; Find line that matches TAG:
  ;; If found, return its value and kill line
  ;; otherwise return nil
  (goto-char (point-min))
  (if (re-search-forward (format "^%s:\\s-*\\(.*\\)" tag) nil t)
      (let ((otext (match-string-no-properties 1)))
	(beginning-of-line)
	(delete-region (point) (progn (forward-line 1) (point)))
	otext)
    nil))

(defun p4-w-make-field (tag tag-len field-len &optional map help-text)
  ;; Create an editable text field.
  ;; Tag is padded to TAG-LEN characters
  ;; Field is FIELD-LEN characters long
  (let ((otext (p4-w-find-and-kill tag)))
    (when otext
      (if (and p4-w-eat-newlines (looking-at "^$"))
	  (delete-region (point) (progn (forward-line 1) (point))))
      (setq tag (concat tag ":" (make-string (max 0 (- tag-len (length tag))) ? )))
      (apply 'widget-create
	     `(editable-field :tag ,tag :value ,otext :sample-face 'font-lock-keyword-face
			      :size ,field-len
			      :format "%{%t%} %v"
			      ,@(if help-text (list :help-echo help-text) nil)
			      ,@(if map (list :keymap map) nil)))
      (widget-insert "\n"))))

(defun p4-w-make-choice (tag len help-text &rest choices)
  ;; Create a menu-choice widget
  ;; Tag is TAG, padded to LEN characters
  ;; HELP-TEXT is a string, or nil
  ;; &rest CHOICES are strings or lists
  ;; Strings (common case) are turned into menu items
  ;; Lists (less common) are used verbatim as widget children
  (let ((otext (p4-w-find-and-kill tag)))
    (when otext
      (if (and p4-w-eat-newlines (looking-at "^$"))
	  (delete-region (point) (progn (forward-line 1) (point))))
      (setq choices
	    (mapcar (lambda (i)
		      (let ((pretty-item (and (stringp i)
					      (cdr (assoc i p4-jm-pretty-name-alist)))))
			(cond ((consp i) i)
			      (pretty-item (list 'item :menu-tag pretty-item i))
			      (t (list 'item i)))))
		    choices))
      (setq tag (concat tag ":" (make-string (max 0 (- len (length tag))) ? )))
      (apply 'widget-create
	     `(menu-choice :tag ,tag :value ,otext
			   :sample-face 'font-lock-keyword-face
			   :format "%{%[%t%]%} %v"
			   ,@(if help-text (list :help-echo help-text) nil)
			   ,@choices)))))

(defun p4-w-make-text (tag &optional map help-text)
  ;; Create a text-area widget
  (when (p4-w-find-and-kill tag)
    (let (begin end val)
      ;; find a chunk of tab-indented text and use it for value
      (setq begin (point))
      (while (and (= (forward-line 1) 0) (looking-at "^\t")))
      (setq end (1- (point)))
      (if (> end begin)
	  (progn
	    (setq val (buffer-substring (1+ begin) end))
	    (delete-region begin end))
	(setq val ""))
      (goto-char begin)
      (apply 'widget-create
	     `(text :value ,val :tag ,tag
		    :format "%{%t:%}\n\t%v"
		    :sample-face font-lock-keyword-face
		    ,@(if help-text (list :help-echo help-text) nil)
		    ,@(if map (list :keymap map) nil)))
      (if (looking-at "^$")
	  (delete-region (point) (progn (forward-line 1) (point)))))))

;;; ----------------------------------------------------------------------
;;; Support for p4-job-mode
;;; ----------------------------------------------------------------------

(defvar p4-jm-jobspec-read-p nil
  "If non-nil the p4-jm-*-fields variables have been initialized.")
(add-hook 'p4-reset-hook (lambda () (setq p4-jm-jobspec-read-p nil)))

(defvar p4-jm-select-fields nil "p4 jobspec fields that are of type 'select'.")
(defvar p4-jm-word-fields nil "p4 jobspec fields that are of type 'word'.")
(defvar p4-jm-text-fields nil "p4 jobspec fields that are of type 'text'.")
(defvar p4-jm-date-fields nil "p4 jobspec fields that are of type 'date'.")
(defconst p4-jm-desired-tag-length
  (apply 'max 0 (mapcar (lambda (f) (length (car f)))
			(append p4-jm-select-fields p4-jm-word-fields)))
  "Desired length of widget tags.")

(defvar p4-jm-widget-map nil
  "Keymap used for widget-ified p4-job-mode.")
(unless p4-jm-widget-map
  (let ((map (copy-keymap widget-keymap)))
    (set-keymap-parent map p4-jm-map)
    (define-key map [mouse-1] 'p4-widget-move-and-invoke)
    (define-key map [down-mouse-2] nil)
    (setq p4-jm-widget-map map)))

(defvar p4-jm-field-widget-map nil
  "Keymap used for widget-ified p4-job-mode.")
(unless p4-jm-field-widget-map
  (let ((map (copy-keymap widget-field-keymap)))
    (set-keymap-parent map p4-jm-map)
    (define-key map [down-mouse-2] nil)
    (setq p4-jm-field-widget-map map)))

(defvar p4-jm-text-widget-map nil
  "Keymap used for widget-ified p4-job-mode.")
(unless p4-jm-text-widget-map
  (let ((map (copy-keymap widget-text-keymap)))
    (set-keymap-parent map p4-jm-map)
    (define-key map "\C-m" (lambda () (interactive) (insert "\n\t")))
    (define-key map "\t" nil)
    (define-key map [down-mouse-2] nil)
    (setq p4-jm-text-widget-map map)))

;; for testing
(defun p4-jm-test-widgets () (interactive)
  (let ((buf "tstwid"))
    (and (get-buffer buf) (kill-buffer buf))
    (switch-to-buffer (p4-job-noselect "3" buf))))

(defun p4-jm-helptext (tag)
  (save-excursion
    (goto-char (point-min))
    (if (re-search-forward (format "^#\\s-+%s:\\s-*\\(.*\\)" tag) nil t)
	(match-string-no-properties 1)
      nil)))

(defun p4-jm-widgetify ()
  ;; Adds widgets to a p4-job-mode buffer.
  ;; Called by p4-job-mode if p4-jm-widgetify is non-nil
  (if (not (eq major-mode 'p4-job-mode))
      (error "Not in a p4-job-mode buffer"))
  (p4-jm-read-jobspec)
  (mapcar (lambda (f)
	    (apply 'p4-w-make-choice
		   (car f)
		   p4-jm-desired-tag-length
		   (p4-jm-helptext (car f))
		   (cdr f)))
	  p4-jm-select-fields)
  (mapcar (lambda (f)
	    (apply 'p4-w-make-field (list (elt f 0) p4-jm-desired-tag-length
					  (elt f 1)
					  p4-jm-field-widget-map
					  (p4-jm-helptext (elt f 0)))))
	  p4-jm-word-fields)
  (mapcar (lambda (f)
	    (p4-w-make-text f p4-jm-text-widget-map
			    (p4-jm-helptext f)))
	  p4-jm-text-fields)
  (mapcar (lambda (f)
	    (goto-char (point-min))
	    (when (re-search-forward (concat "^" f ":") nil t)
	      (forward-line 1)
	      (if (and p4-w-eat-newlines (looking-at "^$"))
		  (delete-region (point) (progn (forward-line 1) (point))))))
	  p4-jm-date-fields)

  (goto-char (point-max))
  (or (bolp) (widget-insert "\n"))
  (if (save-excursion (forward-line -1) (not (looking-at "^$")))
      (widget-insert "\n"))
  (widget-insert "# ")
  (widget-create 'push-button :notify (lambda (&rest ignore) (p4-jm-save)) "Save")
  (widget-insert "   ")
  (widget-create 'push-button :notify (lambda (&rest ignore) (p4-jm-save-and-exit)) "Save and Exit")
  (widget-insert "   ")
  (widget-create 'push-button :notify (lambda (&rest ignore) (p4-jm-unwidgetify)) "No widgets")
  ;; so require-final-newline doesn't cause save-buffer to barf
  (widget-insert "\n")

  (goto-char (point-min))
  (when p4-jm-text-fields
    (re-search-forward (concat "^" (car p4-jm-text-fields) ":") nil t)
    (forward-line 1) (forward-char 1))

  (use-local-map p4-jm-widget-map)
  (widget-setup)
  (set-buffer-modified-p nil))

(defun p4-jm-unwidgetify ()
  ;; Remove all widgets and clean up buffer a little bit
  (let ((old-buffer-modified-p (buffer-modified-p))
	(all (overlay-lists)))
    ;; Delete all the overlays.
    (mapcar 'delete-overlay (car all))
    (mapcar 'delete-overlay (cdr all))
    (remove-hook 'before-change-functions 'widget-before-change t)
    (remove-hook 'after-change-functions 'widget-after-change t)
    (remove-hook 'post-command-hook 'widget-add-change t)
    (goto-char (point-max))
    (beginning-of-line)
    (if (looking-at "^#")
	(delete-region (point) (progn (forward-line 1) (point))))
    (if (not old-buffer-modified-p)
	(set-buffer-modified-p nil))
    (use-local-map p4-jm-map)))

(defun p4-jm-read-jobspec ()
  ;; Read in a jobspec and initialize the p4-jm-*-fields variables if
  ;; they haven't already been read in.
  ;; use M-x `p4-reset' to force jobspec to be re-read.
  (when (not p4-jm-jobspec-read-p)
    (setq p4-jm-select-fields nil
	  p4-jm-word-fields nil
	  p4-jm-text-fields nil
	  p4-jm-date-fields nil)
    (save-excursion
      (message "Reading jobspec...")
      (let ((buf (get-buffer-create "tmp-jobspec"))
	    name type len)
	(p4-exec-p4-fast buf "jobspec" "-o")
	(set-buffer buf)
	(goto-char (point-min))
	(while (re-search-forward "^\t1[0-9][0-9] \\([^ \t\n]+\\) \\(\\sw+\\) \\([0-9]+\\)" nil t)
	  (setq name (match-string 1) type (match-string 2) len (match-string 3))
	  (cond ((string= name "Job") nil)	; ignore Job, because user shouldn't be editing it
		((string= type "text")
		 (add-to-list 'p4-jm-text-fields name))
		((string= type "date")
		 (add-to-list 'p4-jm-date-fields name))
		((string= type "word")
		 (add-to-list 'p4-jm-word-fields (list name (string-to-int len))))))

	(goto-char (point-min))
	(while (re-search-forward "^Values-\\(\\sw+\\):\\s-*\\([^ \t\n]+\\)" nil t)
	  (let ((name (match-string 1))
		(values (split-string (match-string 2) "/")))
	    (add-to-list 'p4-jm-select-fields (cons name values))))

	(kill-buffer buf))
      (message "Reading jobspec... done"))

    (setq p4-jm-desired-tag-length
	  (apply 'max 0 (mapcar (lambda (f) (length (car f)))

				(append p4-jm-select-fields p4-jm-word-fields))))
    (setq p4-jm-jobspec-read-p t)))