;;; xmtn-status.el --- manage actions for multiple projects

;; Copyright (C) 2009 - 2011 Stephen Leake

;; Author: Stephen Leake
;; Keywords: tools

;; This file 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.
;;
;; This file 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 file; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
;; Boston, MA  02110-1301  USA.

(eval-when-compile
  ;; these have macros we use
  (require 'xmtn-ids))

(eval-and-compile
  ;; these have functions we use
  (require 'xmtn-base)
  (require 'xmtn-conflicts)
  (require 'xmtn-revlist))

(defvar xmtn-status-root ""
  "Buffer-local variable holding multi-workspace root directory.")
(make-variable-buffer-local 'xmtn-status-root)
(put 'xmtn-status-root 'permanent-local t)

(defvar xmtn-status-ewoc nil
  "Buffer-local ewoc for displaying multi-workspace status.
All xmtn-status functions operate on this ewoc.
The elements must all be of class xmtn-status-data.")
(make-variable-buffer-local 'xmtn-status-ewoc)
(put 'xmtn-status-ewoc 'permanent-local t)

(defstruct (xmtn-status-data (:copier nil))
  work             ; workspace directory name relative to xmtn-status-root
  branch           ; GDS branch name (all workspaces have same branch; assumed never changes)
  need-refresh     ; nil | t : if an async process was started that invalidates state data
  head-revs        ; either current head revision or (left, right) if multiple heads
  conflicts-buffer ; *xmtn-conflicts* buffer for merge
  status-buffer    ; *xmtn-status* buffer for commit
  heads            ; 'need-scan | 'at-head | 'need-update | 'need-merge
  (update-review
   'pending)       ; 'pending | 'need-review | 'done
  (local-changes
   'need-scan)     ; 'need-scan | 'need-commit | 'ok
  (conflicts
   'need-scan)     ; 'need-scan | 'need-resolve | 'need-review-resolve-internal | 'resolved | 'none
  )

(defun xmtn-status-work (data)
  (concat xmtn-status-root (xmtn-status-data-work data)))

(defun xmtn-status-need-refresh (elem data local-changes)
  ;; The user has selected an action that will change the state of the
  ;; workspace via mtn actions; set our data to reflect that. If
  ;; local-changes is non-nil, xmtn-status-data-local-changes is set
  ;; to that value.
  (setf (xmtn-status-data-need-refresh data) t)
  (setf (xmtn-status-data-heads data) 'need-scan)
  (setf (xmtn-status-data-conflicts data) 'need-scan)
  (if local-changes (setf (xmtn-status-data-local-changes data) local-changes))
  (ewoc-invalidate xmtn-status-ewoc elem))

(defun xmtn-status-printer (data)
  "Print an ewoc element."
  (insert (dvc-face-add (format "%s\n" (xmtn-status-data-work data)) 'dvc-keyword))

  (if (xmtn-status-data-need-refresh data)
      (insert (dvc-face-add "  need refresh\n" 'dvc-conflict))

    (ecase (xmtn-status-data-local-changes data)
      (need-scan (insert "  local changes not checked\n"))
      (need-commit (insert (dvc-face-add "  need commit\n" 'dvc-header)))
      (ok nil))

    (ecase (xmtn-status-data-conflicts data)
      (need-scan
       (insert "  conflicts need scan\n"))
      (need-resolve
       (insert (dvc-face-add "  need resolve conflicts\n" 'dvc-conflict)))
      (need-review-resolve-internal
       (insert (dvc-face-add "  need review resolve internal\n" 'dvc-header)))
      (resolved
       (insert "  conflicts resolved\n"))
      ((resolved none) nil))

    (ecase (xmtn-status-data-heads data)
      (at-head     nil)
      (need-update
       (insert (dvc-face-add "  need update\n" 'dvc-conflict)))
      (need-merge
       (insert (dvc-face-add "  need merge\n" 'dvc-conflict))))

    (ecase (xmtn-status-data-update-review data)
      (pending nil)
      (need-review (insert "  need update review\n"))
      (done nil))
      ))

(defun xmtn-status-kill-conflicts-buffer (data)
  (if (buffer-live-p (xmtn-status-data-conflicts-buffer data))
      (let ((buffer (xmtn-status-data-conflicts-buffer data)))
        (with-current-buffer buffer (save-buffer))
        (kill-buffer buffer))))

(defun xmtn-status-kill-status-buffer (data)
  (if (buffer-live-p (xmtn-status-data-status-buffer data))
      (kill-buffer (xmtn-status-data-status-buffer data))))

(defun xmtn-status-save-conflicts-buffer (data)
  (if (buffer-live-p (xmtn-status-data-conflicts-buffer data))
      (with-current-buffer (xmtn-status-data-conflicts-buffer data) (save-buffer))))

(defun xmtn-status-clean-1 (data save-conflicts)
  "Clean DATA workspace, kill associated automate session.
If SAVE-CONFLICTS non-nil, don't delete conflicts files."
  (xmtn-automate-kill-session (xmtn-status-work data))
  (xmtn-status-kill-conflicts-buffer data)
  (xmtn-status-kill-status-buffer data)
  (unless save-conflicts
    (xmtn-conflicts-clean (xmtn-status-work data))))

(defun xmtn-status-clean ()
  "Clean current workspace, delete from ewoc"
  (interactive)
  (let* ((elem (ewoc-locate xmtn-status-ewoc))
         (data (ewoc-data elem))
         (inhibit-read-only t))
    (xmtn-status-clean-1 data nil)
    (ewoc-delete xmtn-status-ewoc elem)))

(defun xmtn-status-clean-all (&optional save-conflicts)
  "Clean all remaining workspaces."
  (interactive)
  (ewoc-map 'xmtn-status-clean-1 xmtn-status-ewoc save-conflicts))

(defun xmtn-status-cleanp ()
  "Non-nil if clean & quit is appropriate for current workspace."
  (let ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
    ;; don't check need-refresh here; allow deleting after just doing
    ;; final required action in another buffer.
    (and (member (xmtn-status-data-local-changes data) '(need-scan ok))
         (member (xmtn-status-data-heads data) '(need-scan at-head)))))

(defun xmtn-status-do-refresh-one ()
  (interactive)
  (let* ((elem (ewoc-locate xmtn-status-ewoc))
         (data (ewoc-data elem)))
    (xmtn-status-refresh-one data current-prefix-arg)
    (ewoc-invalidate xmtn-status-ewoc elem)))

(defun xmtn-status-refreshp ()
  "Non-nil if refresh is appropriate for current workspace."
  (let ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
    (or (xmtn-status-data-need-refresh data)
        ;; everything's done, but the user just did mtn sync, and more
        ;; stuff showed up
        (eq 'ok (xmtn-status-data-local-changes data))
        (eq 'at-head (xmtn-status-data-heads data)))))

(defun xmtn-status-update ()
  "Update current workspace."
  (interactive)
  (let* ((elem (ewoc-locate xmtn-status-ewoc))
         (data (ewoc-data elem)))
    (xmtn-status-need-refresh elem data nil)
    (setf (xmtn-status-data-update-review data) 'need-review)
    (let ((default-directory (xmtn-status-work data)))
      (xmtn-dvc-update))
    (xmtn-status-refresh-one data nil)
    (ewoc-invalidate xmtn-status-ewoc elem)))

(defun xmtn-status-updatep ()
  "Non-nil if update is appropriate for current workspace."
  (let ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
    (and (not (xmtn-status-data-need-refresh data))
         (eq 'need-update (xmtn-status-data-heads data)))))

(defun xmtn-status-update-preview ()
  "Preview update for current workspace."
  (interactive)
  (let* ((elem (ewoc-locate xmtn-status-ewoc))
         (data (ewoc-data elem))
	 (default-directory (xmtn-status-work data)))
    (xmtn-dvc-missing)))

(defun xmtn-status-resolve-conflicts ()
  "Resolve conflicts for current workspace."
  (interactive)
  (let* ((elem (ewoc-locate xmtn-status-ewoc))
         (data (ewoc-data elem)))
    (xmtn-status-need-refresh elem data nil)
    (setf (xmtn-status-data-conflicts data) 'need-scan)
    (pop-to-buffer (xmtn-status-data-conflicts-buffer data))))

(defun xmtn-status-resolve-conflictsp ()
  "Non-nil if resolve conflicts is appropriate for current workspace."
  (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
    (and (not (xmtn-status-data-need-refresh data))
         (member (xmtn-status-data-conflicts data)
                 '(need-resolve need-review-resolve-internal)))))

(defun xmtn-status-status ()
  "Show status buffer for current workspace."
  (interactive)
  (let* ((elem (ewoc-locate xmtn-status-ewoc))
         (data (ewoc-data elem)))
    ;; assume they are doing a checkin
    (xmtn-status-need-refresh elem data 'ok)
    (pop-to-buffer (xmtn-status-data-status-buffer data))
    ;; IMPROVEME: create a log-edit buffer now, since we have both a
    ;; status and conflict buffer, and that confuses dvc-log-edit
    ))

(defun xmtn-status-status-ok ()
  "Ignore local changes in current workspace."
  (interactive)
  (let* ((elem (ewoc-locate xmtn-status-ewoc))
         (data (ewoc-data elem)))
    (setf (xmtn-status-data-local-changes data) 'ok)
    (ewoc-invalidate xmtn-status-ewoc elem)))

(defun xmtn-status-statusp ()
  "Non-nil if xmtn-status is appropriate for current workspace."
  (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
    (and (not (xmtn-status-data-need-refresh data))
         (member (xmtn-status-data-local-changes data)
                 '(need-scan need-commit)))))

(defun xmtn-status-update-review ()
  "Review last update for current workspace."
  (interactive)
  (let* ((elem (ewoc-locate xmtn-status-ewoc))
         (data (ewoc-data elem)))
    ;; assume they are adding fixmes
    (xmtn-status-need-refresh elem data 'need-scan)
    (setf (xmtn-status-data-update-review data) 'done)
    (xmtn-update-review (xmtn-status-work data))))

(defun xmtn-status-update-reviewp ()
  "Non-nil if xmtn-status-update-review is appropriate for current workspace."
  (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
    (and (not (xmtn-status-data-need-refresh data))
         (eq 'need-review (xmtn-status-data-update-review data)))))

(defun xmtn-status-merge ()
  "Run merge on current workspace."
  (interactive)
  (let* ((elem (ewoc-locate xmtn-status-ewoc))
         (data (ewoc-data elem))
         (default-directory (xmtn-status-work data)))
    (xmtn-status-save-conflicts-buffer data)
    (xmtn--run-command-sync
     default-directory
     (list
      "explicit_merge"
      (nth 0 (xmtn-status-data-head-revs data))
      (nth 1 (xmtn-status-data-head-revs data))
      (xmtn--tree-default-branch default-directory)
      (if (file-exists-p "_MTN/conflicts")
	  "--resolve-conflicts-file=_MTN/conflicts")
      (xmtn-dvc-log-message)))
    (xmtn-status-refresh-one data nil)
    (ewoc-invalidate xmtn-status-ewoc elem)))

(defun xmtn-status-heads ()
  "Show heads for current workspace."
  (interactive)
  (let* ((elem (ewoc-locate xmtn-status-ewoc))
         (data (ewoc-data elem))
         (default-directory (xmtn-status-work data)))
    (xmtn-status-need-refresh elem data nil)
    (xmtn-view-heads-revlist)))

(defun xmtn-status-headsp ()
  "Non-nil if xmtn-heads is appropriate for current workspace."
  (let* ((data (ewoc-data (ewoc-locate xmtn-status-ewoc))))
    (and (not (xmtn-status-data-need-refresh data))
         (eq 'need-merge (xmtn-status-data-heads data)))))

(defun xmtn-status-quit-save ()
  "Quit, but save conflicts files for later resume."
  (interactive)
  (remove-hook 'kill-buffer-hook 'xmtn-status-clean-all t)
  (xmtn-status-clean-all t)
  (kill-buffer))

(defvar xmtn-status-actions-map
  (let ((map (make-sparse-keymap "actions")))
    (define-key map [?c]  '(menu-item "c) clean/delete"
                                      xmtn-status-clean
                                      :visible (xmtn-status-cleanp)))
    (define-key map [?g]  '(menu-item "g) refresh"
                                      xmtn-status-do-refresh-one
                                      :visible (xmtn-status-refreshp)))
    (define-key map [?i]  '(menu-item "i) ignore local changes"
                                      xmtn-status-status-ok
                                      :visible (xmtn-status-statusp)))
    (define-key map [?6]  '(menu-item "6) preview update"
                                      xmtn-status-update-preview
                                      :visible (xmtn-status-updatep)))
    (define-key map [?5]  '(menu-item "5) update review"
                                      xmtn-status-update-review
                                      :visible (xmtn-status-update-reviewp)))
    (define-key map [?4]  '(menu-item "4) update"
                                      xmtn-status-update
                                      :visible (xmtn-status-updatep)))
    (define-key map [?3]  '(menu-item "3) merge"
                                      xmtn-status-merge
                                      :visible (xmtn-status-headsp)))
    (define-key map [?2]  '(menu-item "2) show heads"
                                      xmtn-status-heads
                                      :visible (xmtn-status-headsp)))
    (define-key map [?1]  '(menu-item "1) resolve conflicts"
                                      xmtn-status-resolve-conflicts
                                      :visible (xmtn-status-resolve-conflictsp)))
    (define-key map [?0]  '(menu-item "0) commit"
                                      xmtn-status-status
                                      :visible (xmtn-status-statusp)))
    map)
  "Keyboard menu keymap used in multiple-status mode.")

(dvc-make-ewoc-next xmtn-status-next xmtn-status-ewoc)
(dvc-make-ewoc-prev xmtn-status-prev xmtn-status-ewoc)

(defvar xmtn-multiple-status-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map "\M-d" xmtn-status-actions-map)
    (define-key map [?g]  'xmtn-status-refresh)
    (define-key map [?m]  'xmtn-status-update-preview)
    (define-key map [?n]  'xmtn-status-next)
    (define-key map [?p]  'xmtn-status-prev)
    (define-key map [?r]  'xmtn-status-update-review)
    (define-key map [?s]  'xmtn-status-quit-save)
    (define-key map [?q]  'dvc-buffer-quit)
    map)
  "Keymap used in `xmtn-multiple-status-mode'.")

(easy-menu-define xmtn-multiple-status-mode-menu xmtn-multiple-status-mode-map
  "Mtn specific status menu."
  `("DVC-Mtn"
    ["Do the right thing"    xmtn-status-actions-map t]
    ["Quit, clean conflicts" dvc-buffer-quit t]
    ["Quit, save conflicts"  xmtn-status-quit-save t]
    ["Preview update"        xmtn-status-update-preview t]
    ["Review update"         xmtn-status-update-review t]
    ))

(define-derived-mode xmtn-multiple-status-mode nil "xmtn-multiple-status"
  "Major mode to show status of multiple workspaces."
  (setq dvc-buffer-current-active-dvc 'xmtn)
  (setq buffer-read-only nil)

  ;; don't do normal clean up stuff
  (set (make-local-variable 'before-save-hook) nil)
  (set (make-local-variable 'write-file-functions) nil)

  (dvc-install-buffer-menu)
  (add-hook 'kill-buffer-hook 'xmtn-status-clean-all nil t)
  (setq buffer-read-only t)
  (buffer-disable-undo)

  (set-buffer-modified-p nil))

(defun xmtn-status-conflicts (data)
  "Return value for xmtn-status-data-conflicts for DATA."
  ;; only called if need merge; two items in head-revs
  (let ((result (xmtn-conflicts-status
		 (xmtn-status-data-conflicts-buffer data) ; buffer
		 (xmtn-status-work data) ; left-work
		 (car (xmtn-status-data-head-revs data)) ; left-rev
		 (xmtn-status-work data) ; right-work
		 (cadr (xmtn-status-data-head-revs data)) ; right-rev
		 (xmtn-status-data-branch data) ; left-branch
		 (xmtn-status-data-branch data) ; right-branch
		 )))
    (setf (xmtn-status-data-conflicts-buffer data) (car result))
    (cadr result)))

(defun xmtn-status-refresh-one (data refresh-local-changes)
  "Refresh DATA."
  (let ((work (xmtn-status-work data)))

    (message "checking heads for %s " work)

    (let ((heads (xmtn--heads work (xmtn-status-data-branch data)))
          (base-rev (xmtn--get-base-revision-hash-id-or-null work)))
      (case (length heads)
        (1
         (setf (xmtn-status-data-head-revs data) (nth 0 heads))
         (setf (xmtn-status-data-conflicts data) 'none)
         (if (string= (xmtn-status-data-head-revs data) base-rev)
             (setf (xmtn-status-data-heads data) 'at-head)
           (setf (xmtn-status-data-heads data) 'need-update)))
        (t
         (setf (xmtn-status-data-head-revs data) (list (nth 0 heads) (nth 1 heads)))
         (setf (xmtn-status-data-heads data) 'need-merge))))

    (message "")

    (if refresh-local-changes
	(progn
	  (setf (xmtn-status-data-local-changes data) 'need-scan)
	  (setf (xmtn-status-data-update-review data) 'need-review)))

    (case (xmtn-status-data-local-changes data)
      (need-scan
       (if (buffer-live-p (xmtn-status-data-status-buffer data))
	   (with-current-buffer (xmtn-status-data-status-buffer data)
	     (xmtn-dvc-status)
	     (setf (xmtn-status-data-local-changes data)
		   (if (not (ewoc-locate dvc-fileinfo-ewoc))
		       'ok
		     'need-commit)))
	 (let ((result (xmtn--status-inventory-sync (xmtn-status-work data))))
	   (setf (xmtn-status-data-status-buffer data) (car result)
		 (xmtn-status-data-local-changes data) (cadr result))) ))
      (t nil))

    (case (xmtn-status-data-heads data)
      (need-merge
       (setf (xmtn-status-data-conflicts data)
             (xmtn-status-conflicts data)))
      (t
       (xmtn-status-kill-conflicts-buffer data)
       (xmtn-conflicts-clean (xmtn-status-work data))
       (setf (xmtn-status-data-conflicts data) 'none)))

    (setf (xmtn-status-data-need-refresh data) nil))

  ;; return non-nil to refresh display as we go along
  t)

(defun xmtn-status-refresh ()
  "Refresh status of each ewoc element. With prefix arg, re-scan for local changes."
  (interactive)
  (ewoc-map 'xmtn-status-refresh-one xmtn-status-ewoc current-prefix-arg)
  (message "done"))

;;;###autoload
(defun xmtn-update-multiple (dir &optional workspaces)
  "Update all projects under DIR."
  (interactive "DUpdate all in (root directory): ")
  (let ((root (file-name-as-directory (expand-file-name (substitute-in-file-name dir)))))

    (if (not workspaces) (setq workspaces (xmtn--filter-non-ws root)))

    (dolist (workspace workspaces)
      (let ((default-directory (concat root workspace)))
        (xmtn-dvc-update nil t)))
    (message "Update %s done" root)))

;;;###autoload
(defun xmtn-status-multiple (dir &optional workspaces skip-initial-scan)
  "Show actions to update all projects under DIR."
  (interactive "DStatus for all (root directory): \ni\nP")
  (pop-to-buffer (get-buffer-create "*xmtn-multi-status*"))
  (setq default-directory (file-name-as-directory (expand-file-name (substitute-in-file-name dir))))
  (if (not workspaces) (setq workspaces (xmtn--filter-non-ws default-directory)))
  (setq xmtn-status-root (file-name-as-directory default-directory))
  (setq xmtn-status-ewoc (ewoc-create 'xmtn-status-printer))
  (let ((inhibit-read-only t)) (delete-region (point-min) (point-max)))
  (ewoc-set-hf xmtn-status-ewoc (format "Root : %s\n" xmtn-status-root) "")
  (dolist (workspace workspaces)
    (ewoc-enter-last xmtn-status-ewoc
                     (make-xmtn-status-data
                      :work workspace
                      :branch (xmtn--tree-default-branch (concat xmtn-status-root workspace))
                      :need-refresh t
                      :heads 'need-scan)))
  (xmtn-multiple-status-mode)
  (when (not skip-initial-scan)
    (progn
      (xmtn-status-refresh)
      (xmtn-status-next))))

;;;###autoload
(defun xmtn-status-one (work)
  "Show actions to update WORK."
  (interactive "DStatus for (workspace): ")
  (pop-to-buffer (get-buffer-create "*xmtn-multi-status*"))
  ;; allow WORK to be relative, and ensure it is a workspace root
  (setq default-directory (xmtn-tree-root (expand-file-name work)))
  (setq xmtn-status-root (expand-file-name (concat (file-name-as-directory default-directory) "../")))
  (setq xmtn-status-ewoc (ewoc-create 'xmtn-status-printer))
  ;; FIXME: sometimes, this causes problems for ewoc-set-hf (deletes bad region)
  ;; But otherwise it is necessary to clean out old ewoc before creating new one.
  (let ((inhibit-read-only t)) (delete-region (point-min) (point-max)))
  (ewoc-set-hf xmtn-status-ewoc (format "Root : %s\n" xmtn-status-root) "")
  (ewoc-enter-last xmtn-status-ewoc
                   (make-xmtn-status-data
                    :work (file-name-nondirectory (directory-file-name default-directory))
                    :branch (xmtn--tree-default-branch default-directory)
                    :need-refresh t
                    :heads 'need-scan))
  (xmtn-multiple-status-mode)
  (xmtn-status-refresh)
  (xmtn-status-next))

;;;###autoload
(defun xmtn-status-one-1 (root name head-revs status-buffer heads local-changes)
  "Create an xmtn-multi-status buffer from xmtn-propagate."
  (pop-to-buffer (get-buffer-create "*xmtn-multi-status*"))
  (setq default-directory (concat root "/" name))
  (setq xmtn-status-root root)
  (setq xmtn-status-ewoc (ewoc-create 'xmtn-status-printer))
  (let ((inhibit-read-only t)) (delete-region (point-min) (point-max)))
  (ewoc-set-hf xmtn-status-ewoc (format "Root : %s\n" xmtn-status-root) "")
  (ewoc-enter-last xmtn-status-ewoc
                   (make-xmtn-status-data
                    :work (file-name-nondirectory (directory-file-name default-directory))
                    :branch (xmtn--tree-default-branch default-directory)
                    :need-refresh nil
		    :head-revs head-revs
		    :conflicts-buffer nil
		    :status-buffer status-buffer
                    :heads heads
		    :local-changes local-changes
		    :conflicts 'need-scan))
  (xmtn-multiple-status-mode)
  (xmtn-status-refresh))

(provide 'xmtn-multi-status)

;; end of file