;;; xmtn-dvc.el --- DVC backend for monotone

;; Copyright (C) 2008 - 2009 Stephen Leake
;; Copyright (C) 2006, 2007, 2008 Christian M. Ohler

;; Author: Christian M. Ohler
;; 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.

;;; Commentary:

;; This file implements a DVC backend for the distributed version
;; control system monotone.  The backend will only work with an
;; appropriate version of the mtn binary installed.

;;; Code:

;;; There are some notes on the design of xmtn in
;;; docs/xmtn-readme.txt.

(eval-and-compile
  (require 'cl)
  (require 'dvc-unified)
  (require 'xmtn-basic-io)
  (require 'xmtn-base)
  (require 'xmtn-run)
  (require 'xmtn-automate)
  (require 'xmtn-conflicts)
  (require 'xmtn-ids)
  (require 'xmtn-match)
  (require 'xmtn-minimal)
  (require 'dvc-log)
  (require 'dvc-diff)
  (require 'dvc-status)
  (require 'dvc-core)
  (require 'ewoc))

;; For debugging.
(defun xmtn--load ()
  (require 'dvc-unified)
  (save-some-buffers)
  (mapc (lambda (file)
          (byte-compile-file file t))
        '("xmtn-minimal.el"
          "xmtn-compat.el"
          "xmtn-match.el"
          "xmtn-base.el"
          "xmtn-run.el"
          "xmtn-automate.el"
          "xmtn-basic-io.el"
          "xmtn-ids.el"
          "xmtn-dvc.el"
          "xmtn-revlist.el")))
;;; (xmtn--load)

;;;###autoload
(dvc-register-dvc 'xmtn "monotone")

(defmacro* xmtn--with-automate-command-output-basic-io-parser
    ((parser root-form command-form &key ((:may-kill-p may-kill-p-form)))
     &body body)
  (declare (indent 1) (debug (sexp body)))
  (let ((parser-tmp (gensym))
        (root (gensym))
        (command (gensym))
        (may-kill-p (gensym))
        (session (gensym))
        (handle (gensym)))
    `(let ((,root ,root-form)
           (,command ,command-form)
           (,may-kill-p ,may-kill-p-form))
       (let* ((,session (xmtn-automate-cache-session ,root))
              (,handle (xmtn-automate--new-command ,session ,command ,may-kill-p)))
         (xmtn-automate-command-check-for-and-report-error ,handle)
         (xmtn-automate-command-wait-until-finished ,handle)
         (xmtn-basic-io-with-stanza-parser (,parser
                                            (xmtn-automate-command-buffer
                                             ,handle))
           ,@body)))))

;;;###autoload
(defun xmtn-dvc-log-edit-file-name-func (&optional root)
  (concat (file-name-as-directory (or root (dvc-tree-root)))
          "_MTN/log"))

(defun xmtn--toposort (root revision-hash-ids)
  (xmtn-automate-simple-command-output-lines root
                                             `("toposort"
                                               ,@revision-hash-ids)))

(add-to-list 'format-alist
             '(xmtn--log-file
               "This format automatically removes xmtn's log edit hints from
the file before saving."
               nil
               xmtn--log-file-format-from-fn
               xmtn--log-file-format-to-fn
               t
               nil
               nil))

(defun xmtn--log-file-format-from-fn (begin end)
  (xmtn--assert-nil))

(defun xmtn--log-file-format-to-fn (begin end buffer)
  (dvc-log-flush-commit-file-list))

;;;###autoload
(defun xmtn-dvc-log-edit (root other-frame no-init)
  (if no-init
      (dvc-dvc-log-edit root other-frame no-init)
    (progn
      (dvc-dvc-log-edit root other-frame nil)
      (setq buffer-file-coding-system 'xmtn--monotone-normal-form) ;; FIXME: move this into dvc-get-buffer-create?
      (add-to-list 'buffer-file-format 'xmtn--log-file) ;; FIXME: generalize to dvc--log-file
      )))

(defun xmtn-dvc-log-message ()
  "Return --message-file argument string, if any."
  (let ((log-edit-file "_MTN/log"))
    (if (file-exists-p log-edit-file)
        (concat "--message-file=" log-edit-file))))

;;;###autoload
(defun xmtn-dvc-log-edit-done ()
  (let* ((root default-directory)
         (files (or (with-current-buffer dvc-partner-buffer
                      (dvc-current-file-list 'nil-if-none-marked))
                    'all))
         (normalized-files
          (case files
            (all 'all)
            (t
             ;; Need to normalize in original buffer, since
             ;; switching buffers changes default-directory and
             ;; therefore the semantics of relative file names.
             (with-current-buffer dvc-partner-buffer
               (xmtn--normalize-file-names root files)))))
         (excluded-files
          (with-current-buffer dvc-partner-buffer
            (xmtn--normalize-file-names root (dvc-fileinfo-excluded-files))))
         (branch (xmtn--tree-default-branch root)))
    ;; Saving the buffer will automatically delete any log edit hints.
    (save-buffer)
    (dvc-save-some-buffers root)

    ;; check that the first line says something; it should be a summary of the rest
    (goto-char (point-min))
    (forward-line)
    (if (= (point) (1+ (point-min)))
        (error "Please put a summary comment on the first line"))

    ;; We used to check for things that would make commit fail;
    ;; missing files, nothing to commit. But that just slows things
    ;; down in the typical case; better to just handle the error
    ;; message, which is way more informative anyway.
    (lexical-let* ((progress-message
                    (case normalized-files
                      (all (format "Committing all files in %s" root))
                      (t (case (length normalized-files)
                           (0 (assert nil))
                           (1 (format "Committing file %s in %s"
                                      (first normalized-files) root))
                           (t
                            (format "Committing %s files in %s"
                                    (length normalized-files)
                                    root)))))))
      (xmtn--run-command-async
       root
       `("commit" ,(xmtn-dvc-log-message)
         ,(concat "--branch=" branch)
         ,@(case normalized-files
             (all
              (if excluded-files
                  (mapcar (lambda (file) (concat "--exclude=" file)) excluded-files)
                '()))
             (t (list*
                 ;; Since we are specifying files explicitly, don't
                 ;; recurse into specified directories. Also commit
                 ;; normally excluded files if they are selected.
                 "--depth=0"
                 "--" normalized-files))))
       :error (lambda (output error status arguments)
                (dvc-default-error-function output error
                                            status arguments))
       :killed (lambda (output error status arguments)
                 (dvc-default-killed-function output error
                                              status arguments))
       :finished (lambda (output error status arguments)
                   (message "%s... done" progress-message)
                   ;; Monotone creates an empty log file when the
                   ;; commit was successful.  Let's not interfere with
                   ;; that.  (Calling `dvc-log-close' would.)

                   ;; we'd like to delete log-edit-buffer here, but
                   ;; we can't do that from a process sentinel

                   (dvc-diff-clear-buffers 'xmtn
                                           default-directory
                                           "* Just committed! Please refresh buffer"
                                           (xmtn--status-header
                                            default-directory
                                            (xmtn--get-base-revision-hash-id-or-null default-directory)))
                   ))

       ;; Show message _after_ spawning command to override DVC's
       ;; debugging message.
       (message "%s... " progress-message))
    (set-window-configuration dvc-pre-commit-window-configuration)))

;; The term "normalization" here has nothing to do with Unicode
;; normalization.
(defun xmtn--normalize-file-name (root file-name)
  (assert root)
  (let ((normalized-name (file-relative-name file-name root)))
    normalized-name))

(defun xmtn--normalize-file-names (root file-names)
  (check-type file-names list)
  (mapcar (lambda (file-name) (xmtn--normalize-file-name root file-name))
          file-names))

(defun xmtn--display-buffer-maybe (buffer dont-switch)
  (let ((orig-buffer (current-buffer)))
    (if dvc-switch-to-buffer-first
        (dvc-switch-to-buffer buffer)
      (set-buffer buffer))
    (when dont-switch (pop-to-buffer orig-buffer)))
  nil)

(defun xmtn--status-header (root base-revision)
  (let* ((branch (xmtn--tree-default-branch root))
         (head-revisions (xmtn--heads root branch))
         (head-count (length head-revisions)))

    (concat
      (format "Status for %s:\n" root)
      (if base-revision
          (format "  base revision %s\n" base-revision)
        "  tree has no base revision\n")
      (format "  branch %s\n" branch)
      (case head-count
        (0 "  branch is empty\n")
        (1 "  branch is merged\n")
        (t (dvc-face-add (format "  branch has %s heads; need merge\n" head-count) 'dvc-conflict)))
      (if (member base-revision head-revisions)
          "  base revision is a head revision\n"
        (dvc-face-add "  base revision is not a head revision; need update\n" 'dvc-conflict)))))

(defun xmtn--refresh-status-header (status-buffer)
  (with-current-buffer status-buffer
    ;; different modes use different names for the ewoc
    ;; FIXME: should have a separate function for each mode
    (if dvc-fileinfo-ewoc
      (ewoc-set-hf
       dvc-fileinfo-ewoc
       (xmtn--status-header default-directory (xmtn--get-base-revision-hash-id-or-null default-directory))
       ""))))

(defun xmtn--parse-diff-for-dvc (changes-buffer)
  (let ((excluded-files (dvc-default-excluded-files))
        matched)
    (flet ((add-entry
            (path status dir &optional orig-path)
            (with-current-buffer changes-buffer
              (ewoc-enter-last
               dvc-fileinfo-ewoc
               (if dir
                   (make-dvc-fileinfo-dir
                    :mark nil
                    :exclude (dvc-match-excluded excluded-files path)
                    :dir (file-name-directory path)
                    :file (file-name-nondirectory path)
                    :status status
                    :more-status "")
                 (make-dvc-fileinfo-file
                  :mark nil
                  :exclude (dvc-match-excluded excluded-files path)
                  :dir (file-name-directory path)
                  :file (file-name-nondirectory path)
                  :status status
                  :more-status (if orig-path
                                   (if (eq status 'rename-target)
                                       (concat "from " orig-path)
                                     (concat "to " orig-path))
                                 ""))))))
           (likely-dir-p (path) (string-match "/\\'" path)))

      ;; First parse the basic_io contained in dvc-header, if any.
      (let ((revision
             (with-temp-buffer
               (insert dvc-header)
               (goto-char (point-min))
               (while (re-search-forward "^# ?" nil t)
                 (replace-match ""))
               (goto-char (point-min))
               (xmtn-basic-io-skip-blank-lines)
               (delete-region (point-min) (point))
               (xmtn-basic-io-with-stanza-parser
                   (parser (current-buffer))
                 (xmtn--parse-partial-revision parser)))))
        (loop
         for (path) in (xmtn--revision-delete revision)
         do (add-entry path 'deleted (likely-dir-p path)))
        (loop
         for (from to) in (xmtn--revision-rename revision)
         do (assert (eql (not (likely-dir-p from))
                         (not (likely-dir-p to))))
         do (add-entry to 'rename-target (likely-dir-p to) from)
         do (add-entry from 'rename-source (likely-dir-p from) to))
        (loop
         for (path) in (xmtn--revision-add-dir revision)
         do (add-entry path 'added t))
        (loop
         for (path contents)
         in (xmtn--revision-add-file revision)
         do (add-entry path 'added nil))
        (loop
         for (path from-contents to-contents)
         in (xmtn--revision-patch-file revision)
         do (add-entry path 'modified nil))
        ;; Do nothing about clear-attr and set-attr.
        ))

    (setq dvc-header
          (with-current-buffer changes-buffer
            (xmtn--status-header default-directory (xmtn--revision-hash-id dvc-diff-base))))
    nil))

;;;###autoload
(defun xmtn-show-base-revision ()
  "Show the base revision of the current monotone tree in the minibuffer."
  (interactive)
  (let* ((root (dvc-tree-root))
         (hash-id-or-null (xmtn--get-base-revision-hash-id-or-null root)))
    (if hash-id-or-null
        (message "Base revision of tree %s is %s" root hash-id-or-null)
      (message "Tree %s has no base revision" root))))


;;;###autoload
(defun xmtn-dvc-search-file-in-diff (file)
  (re-search-forward
   (let ((quoted-file (regexp-quote file)))
     (concat "^\\(\\("
             "\\+\\+\\+ " quoted-file
             "\\)\\|\\("
             ;; FIXME: What `dvc-diff-diff-or-list' does doesn't work
             ;; for this case, since `diff-hunk-next' doesn't recognize
             ;; mtn's output for this case as a diff hunk.
             "# " quoted-file " is binary"
             "\\)\\)$"))))


;;;###autoload
(defun xmtn-dvc-diff (&optional rev path dont-switch)
  ;; If rev is an ancestor of base-rev of path, then rev is from, path
  ;; is 'to', and vice versa.
  ;;
  ;; Note rev might be a string mtn selector, so we have to use
  ;; resolve-revision-id to process it.
  (let ((workspace (list 'xmtn (list 'local-tree (xmtn-tree-root path))))
        (base (xmtn--get-base-revision-hash-id-or-null path))
        (rev-string (cadr (xmtn--resolve-revision-id path rev))))
    (if (string= rev-string base)
        ;; local changes in workspace are 'to'
        (xmtn-dvc-delta rev workspace dont-switch)
      (let ((descendents (xmtn-automate-simple-command-output-lines path (list "descendents" base)))
            (done nil))
        (while descendents
          (if (string= rev-string (car descendents))
              ;; rev is newer than workspace; rev is 'to'
              (progn
                (xmtn-dvc-delta workspace rev dont-switch)
                (setq done t)))
          (setq descendents (cdr descendents)))
        (if (not done)
            ;; rev is ancestor of workspace; workspace is 'to'
            (xmtn-dvc-delta rev workspace dont-switch))))))

(defvar xmtn-diff-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map "CM" 'xmtn-conflicts-merge)
    (define-key map "CP" 'xmtn-conflicts-propagate)
    (define-key map "CR" 'xmtn-conflicts-review)
    (define-key map "CC" 'xmtn-conflicts-clean)
    (define-key map "MH" 'xmtn-view-heads-revlist)
    (define-key map "MP" 'xmtn-propagate-from)
    map))

;; items added here should probably also be added to xmtn-revlist-mode-menu, -map in xmtn-revlist.el
(easy-menu-define xmtn-diff-mode-menu xmtn-diff-mode-map
  "Mtn specific diff menu."
  `("DVC-Mtn"
    ["View Heads" xmtn-view-heads-revlist t]
    ["Show propagate conflicts" xmtn-conflicts-propagate t]
    ["Review conflicts" xmtn-conflicts-review t]
    ["Propagate branch" xmtn-propagate-from t]
    ["Clean conflicts resolutions" xmtn-conflicts-clean t]
    ))

(define-derived-mode xmtn-diff-mode dvc-diff-mode "xmtn-diff"
  "Add back-end-specific commands for dvc-diff.")

(dvc-add-uniquify-directory-mode 'xmtn-diff-mode)

(defun xmtn--rev-to-option (resolved from)
  "Return a string contaiing the mtn diff command-line option for RESOLVED-REV.
If FROM is non-nil, RESOLVED-REV is assumed older than workspace;
otherwise newer."
  (ecase (car resolved)
    ('local-tree
     (if from
         (progn
           ;; FIXME: --reverse is not in mtn 0.44; bump overall
           ;; required version on new mtn release
           (let ((xmtn--minimum-required-command-version '(0 45)))
             (xmtn--check-cached-command-version)
             "--reverse"))
       ""))
    ('revision (concat "--revision=" (cadr resolved)))))

;;;###autoload
(defun xmtn-dvc-delta (from-revision-id to-revision-id &optional dont-switch)
  ;; See dvc-unified.el dvc-delta for doc string. If strings, they must be mtn selectors.
  (let* ((root (dvc-tree-root))
         (from-resolved (xmtn--resolve-revision-id root from-revision-id))
         (to-resolved (xmtn--resolve-revision-id root to-revision-id)))
    (let ((diff-buffer
           (dvc-prepare-changes-buffer `(xmtn ,from-resolved) `(xmtn ,to-resolved) 'diff root 'xmtn))
          (rev-specs (list (xmtn--rev-to-option from-resolved t)
                           (xmtn--rev-to-option to-resolved nil))))
      (buffer-disable-undo diff-buffer)
      (dvc-save-some-buffers root)
      (lexical-let* ((diff-buffer diff-buffer))
        (xmtn--run-command-async
         root `("diff" ,@rev-specs)
         :related-buffer diff-buffer
         :finished
         (lambda (output error status arguments)
           (with-current-buffer output
             (xmtn--remove-content-hashes-from-diff))
           (dvc-show-changes-buffer output 'xmtn--parse-diff-for-dvc
                                    diff-buffer t "^="))))

      (xmtn--display-buffer-maybe diff-buffer dont-switch)

      ;; The call site in `dvc-revlist-diff' needs this return value.
      diff-buffer)))

(defvar xmtn-status-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map "CM" 'xmtn-conflicts-merge)
    (define-key map "CP" 'xmtn-conflicts-propagate)
    (define-key map "CR" 'xmtn-conflicts-review)
    (define-key map "CC" 'xmtn-conflicts-clean)
    (define-key map "MP" 'xmtn-propagate-from)
    (define-key map "MH" 'xmtn-view-heads-revlist)
    map))

(easy-menu-define xmtn-status-mode-menu xmtn-status-mode-map
  "Mtn specific status menu."
  `("DVC-Mtn"
    ["View Heads" xmtn-view-heads-revlist t]
    ["Show merge conflicts" xmtn-conflicts-merge t]
    ["Show propagate conflicts" xmtn-conflicts-propagate t]
    ["Review conflicts" xmtn-conflicts-review t]
    ["Propagate branch" xmtn-propagate-from t]
    ["Clean conflicts resolutions" xmtn-conflicts-clean t]
    ))

(define-derived-mode xmtn-status-mode dvc-status-mode "xmtn-status"
  "Add back-end-specific commands for dvc-status.")

(add-to-list 'uniquify-list-buffers-directory-modes 'xmtn-status-mode)

(defun xmtn--remove-content-hashes-from-diff ()
  ;; Hack: Remove mtn's file content hashes from diff headings since
  ;; `dvc-diff-diff-or-list' and `dvc-diff-find-file-name' gets
  ;; confused by them.
  (save-excursion
    (goto-char (point-min))
    (while
        (re-search-forward
         "^\\(\\+\\+\\+\\|---\\) \\(.*\\)\\(\t[0-9a-z]\\{40\\}\\)$"
         nil t)
      (replace-match "" t nil nil 3))))


(defun xmtn--simple-finished-notification (buffer)
  (lexical-let ((buffer buffer))
    (lambda (output error status arguments)
      (message "Process %s finished" buffer))))

;;;###autoload
(defun xmtn-dvc-command-version ()
  (fourth (xmtn--command-version xmtn-executable)))

(defvar xmtn-dvc-automate-version nil
  "Cached value of mtn automate interface version.")

(defun xmtn-dvc-automate-version ()
  "Return mtn automate version as a number."
  (if xmtn-dvc-automate-version
      xmtn-dvc-automate-version
    (setq xmtn-dvc-automate-version
          (string-to-number (xmtn--command-output-line nil '("automate" "interface_version"))))))

(defun xmtn--changes-image (change)
  (ecase change
    (content "content")
    (attrs   "attrs  ")))

(defun xmtn--status-process-entry (ewoc path status changes old-path new-path
                                        old-type new-type fs-type
                                        excluded-files)
  "Create a file entry in ewoc."
  ;; Don't display root directory (""); if requested, don't
  ;; display known or ignored files.
  (if (and (or (not (equal '(known) status))
               (member 'content changes)
               dvc-status-display-known)
           (or (not (equal '(ignored) status))
               dvc-status-display-ignored)
           (not (equal path "")))
      (let ((main-status
             (or
              (if (member 'added status) 'added)
              (if (member 'deleted status) 'deleted)
              (if (member 'ignored status) 'ignored)
              (if (member 'invalid status) 'invalid)
              (if (member 'missing status) 'missing)
              (if (member 'rename-source status) 'rename-source)
              (if (member 'rename-target status) 'rename-target)
              (if (member 'unknown status) 'unknown)
              ;; check for known last; almost everything is known
              (if (member 'known status)
                  (if (member 'content changes)
                      'modified
                    'known))))

            (indexed (not (eq status 'missing))) ;; in terse mode, missing is represented as "D?"
            (more-status "")
            basic-need-more-status)

        (setq basic-need-more-status
              (or (not (equal status (list main-status)))
                  (not (eq changes nil))))

        (case main-status
          (added
           ;; if the file has been modified since is was marked
           ;; 'added', that's still just 'added', so we never need to
           ;; do anything here.
           nil)

          ((deleted missing)
           (if basic-need-more-status
               (setq more-status
                     (concat
                      (mapconcat 'dvc-fileinfo-status-image-full (delq main-status status) " ")
                      (mapconcat 'xmtn--changes-image changes " ")))))

          ((ignored invalid) nil)


          (rename-source
           (setq more-status
                 (concat "to " new-path)))

          (rename-target
           (setq more-status
                 (concat "from " old-path)))

          (modified
           (if (and (equal status '(known))
                    (equal changes '(content)))
               ;; just modified, nothing else
               nil
             (if basic-need-more-status
                 (setq more-status
                       (concat
                        (mapconcat 'dvc-fileinfo-status-image-full (delq main-status status) " ")
                        (mapconcat 'xmtn--changes-image changes " "))))))

          (known
           (if basic-need-more-status
               (setq more-status
                     (concat
                      (mapconcat 'dvc-fileinfo-status-image-full (delq main-status status) " ")
                      (mapconcat 'xmtn--changes-image changes " ")))))
          )

        (case (if (equal fs-type 'none)
                  (if (equal old-type 'none)
                      new-type
                    old-type)
                fs-type)
          (directory
           (ewoc-enter-last ewoc
                            (make-dvc-fileinfo-dir
                             :mark nil
                             :exclude (dvc-match-excluded excluded-files path)
                             :dir (file-name-directory path)
                             :file (file-name-nondirectory path)
                             :status main-status
                             :indexed indexed
                             :more-status more-status)))
          ((file none)
           ;; 'none' indicates a dropped (deleted) file
           (ewoc-enter-last ewoc
                            (make-dvc-fileinfo-file
                             :mark nil
                             :exclude (dvc-match-excluded excluded-files path)
                             :dir (file-name-directory path)
                             :file (file-name-nondirectory path)
                             :status main-status
                             :indexed indexed
                             :more-status more-status)))
          (t
           (error "path %s fs-type %s old-type %s new-type %s" path fs-type old-type new-type))
          ))))

(defun xmtn--parse-inventory (stanza-parser fn)
  (loop for stanza = (funcall stanza-parser)
        while stanza do
        (xmtn-match stanza
          ((("path" (string $path))
            . $rest)
           (let* ((status (loop for entry in (cdr (assoc "status" rest))
                                collect
                                (xmtn-match entry
                                  ((string "added") 'added)
                                  ((string "dropped") 'deleted)
                                  ((string "invalid") 'invalid)
                                  ((string "known") 'known)
                                  ((string "missing") 'missing)
                                  ((string "ignored") 'ignored)
                                  ((string "unknown") 'unknown)
                                  ((string "rename_target") 'rename-target)
                                  ((string "rename_source") 'rename-source))))
                  (fs-type (xmtn-match (cdr (assoc "fs_type" rest))
                             (((string "file")) 'file)
                             (((string "directory")) 'directory)
                             (((string "none")) 'none)))
                  (old-type (xmtn-match (cdr (assoc "new_type" rest))
                              (((string "file")) 'file)
                              (((string "directory")) 'directory)
                              (nil 'none)))
                  (new-type (xmtn-match (cdr (assoc "new_type" rest))
                              (((string "file")) 'file)
                              (((string "directory")) 'directory)
                              (nil 'none)))
                  (changes (loop for entry in (cdr (assoc "changes" rest))
                                 collect
                                 (xmtn-match entry
                                   ((string "content") 'content)
                                   ((string "attrs") 'attrs))))
                  (old-path-or-null (xmtn-match (cdr (assoc "old_path" rest))
                                      (((string $old-path)) old-path)
                                      (nil nil)))
                  (new-path-or-null (xmtn-match (cdr (assoc "new_path" rest))
                                      (((string $new-path)) new-path)
                                      (nil nil)))
                  )
             (funcall fn
                      path
                      status
                      changes
                      old-path-or-null
                      new-path-or-null
                      old-type
                      new-type
                      fs-type))))))

(defun xmtn--status-using-inventory (root)
  ;; We don't run automate inventory through xmtn-automate here as
  ;; that would block.  xmtn-automate doesn't support asynchronous
  ;; command execution yet.
  (let*
      ((base-revision (xmtn--get-base-revision-hash-id-or-null root))
       (branch (xmtn--tree-default-branch root))
       (head-revisions (xmtn--heads root branch))
       (head-count (length head-revisions))
       (status-buffer
        (dvc-status-prepare-buffer
         'xmtn
         root
         ;; FIXME: just pass header
         ;; base-revision
         (if base-revision (format "%s" base-revision) "none")
         ;; branch
         (format "%s" branch)
         ;; header-more
         (lambda ()
           (concat
            (case head-count
              (0 "  branch is empty\n")
              (1 "  branch is merged\n")
              (t (dvc-face-add (format "  branch has %s heads; need merge\n" head-count) 'dvc-conflict)))
            (if (member base-revision head-revisions)
                "  base revision is a head revision\n"
              (dvc-face-add "  base revision is not a head revision; need update\n" 'dvc-conflict))))
         ;; refresh
         'xmtn-dvc-status)))
    (dvc-save-some-buffers root)
    (lexical-let* ((status-buffer status-buffer))
      (xmtn--run-command-async
       root `("automate" "inventory"
              ,@(and (xmtn--have-no-ignore)
                     (not dvc-status-display-known)
                     '("--no-unchanged"))
              ,@(and (xmtn--have-no-ignore)
                     (not dvc-status-display-ignored)
                     '("--no-ignored")))
       :finished (lambda (output error status arguments)
                   (dvc-status-inventory-done status-buffer)
                   (with-current-buffer status-buffer
                     (let ((excluded-files (dvc-default-excluded-files)))
                       (xmtn-basic-io-with-stanza-parser
                           (parser output)
                         (xmtn--parse-inventory
                          parser
                          (lambda (path status changes old-path new-path
                                        old-type new-type fs-type)
                            (xmtn--status-process-entry dvc-fileinfo-ewoc
                                                        path status
                                                        changes
                                                        old-path new-path
                                                        old-type new-type
                                                        fs-type
                                                        excluded-files))))
                       (when (not (ewoc-locate dvc-fileinfo-ewoc))
                         (ewoc-enter-last dvc-fileinfo-ewoc
                                          (make-dvc-fileinfo-message
                                           :text (concat " no changes in workspace")))
                         (ewoc-refresh dvc-fileinfo-ewoc)))))
       :error (lambda (output error status arguments)
                ;; FIXME: need `dvc-status-error-in-process', or change name.
                (dvc-diff-error-in-process
                 status-buffer
                 (format "Error running mtn with arguments %S" arguments)
                 output error))
       :killed (lambda (output error status arguments)
                 ;; Create an empty buffer as a fake output buffer to
                 ;; avoid printing all the output so far.
                 (with-temp-buffer
                   (dvc-diff-error-in-process
                    status-buffer
                    (format "Received signal running mtn with arguments %S"
                            arguments)
                    (current-buffer) error)))))))

;;;###autoload
(defun xmtn-dvc-status ()
  "Display status of monotone tree at `default-directory'."
  (xmtn--status-using-inventory default-directory))

;;;###autoload
(defun xmtn-dvc-revision-direct-ancestor (revision-id)
  (let* ((root (dvc-tree-root))
         (resolved-id (xmtn--resolve-revision-id root revision-id)))
    `(xmtn ,(xmtn--resolve-backend-id root
                                      `(previous-revision ,resolved-id 1)))))

;;;###autoload
(defun xmtn-dvc-name-construct (backend-revision)
  (check-type backend-revision xmtn--hash-id)
  backend-revision)

(defun xmtn--mtnignore-file-name (root)
  (concat (file-name-as-directory root) ".mtn-ignore"))

;;;###autoload
(defun xmtn-dvc-edit-ignore-files ()
  (find-file-other-window (xmtn--mtnignore-file-name (dvc-tree-root))))

(defun xmtn--quote-string-as-partial-perl-regexp (string)
  ;; The set of file names/patterns to be ignored by monotone is
  ;; customizable by the user through a hook.  So we can't guarantee
  ;; that writing something to .mtn-ignore really has the desired
  ;; effect.  However, we implement the correct behavior for the
  ;; default hook.
  ;;
  ;; The default hook uses the function regex.search, which is defined
  ;; in lua.cc, which, as of monotone revision
  ;; 341e4a18c594cec49896fa97bd4e74de7bee5827, uses Boost.Regex with
  ;; the default settings (Perl syntax).
  ;;
  ;; http://www.boost.org/libs/regex/doc/syntax_perl.html describes
  ;; this syntax.  This implementation is based on that description.
  (let ((special-chars ".[{()\*+?|^$"))
    (with-output-to-string
      (loop for char across string
            do
            (when (position char special-chars) (write-char ?\\))
            (write-char char)))))

(defun xmtn--perl-regexp-for-extension (extension)
  (format "\\.%s$" (xmtn--quote-string-as-partial-perl-regexp extension)))

(defun xmtn--perl-regexp-for-file-name (file-name)
  (format "^%s$" (xmtn--quote-string-as-partial-perl-regexp file-name)))

(defun xmtn--perl-regexp-for-files-in-directory (directory-file-name)
  (format "^%s" (xmtn--quote-string-as-partial-perl-regexp
                 (file-name-as-directory directory-file-name))))

(defun xmtn--perl-regexp-for-extension-in-dir (file-name)
  (format "^%s.*\\.%s$"
          (xmtn--quote-string-as-partial-perl-regexp
           (file-name-directory file-name))
          (xmtn--quote-string-as-partial-perl-regexp
           (file-name-extension file-name))))

(defun xmtn--add-patterns-to-mtnignore (root patterns interactive-p)
    (save-window-excursion
      ;; use 'find-file-other-window' to preserve current state if
      ;; user is already visiting the ignore file.
      (find-file-other-window (xmtn--mtnignore-file-name root))
      (save-excursion
        (let ((modified-p nil))
          (loop for pattern in patterns
                do
                (goto-char (point-min))
                (unless (re-search-forward (concat "^" (regexp-quote pattern)
                                                   "$")
                                           nil t)
                  (goto-char (point-max))
                  (unless (bolp) (insert "\n"))
                  (insert pattern "\n")
                  (setq modified-p t)))
          (when modified-p
            ;; 'sort-lines' moves all markers, which defeats save-excursion. Oh well!
            (sort-lines nil (point-min) (point-max))
            (if (and interactive-p
                     dvc-confirm-ignore)
                (lexical-let ((buffer (current-buffer)))
                  (save-some-buffers nil (lambda ()
                                           (eql (current-buffer) buffer))))
              (save-buffer))))))
    nil)

;;;###autoload
(defun xmtn-dvc-ignore-files (file-names)
  (assert (not (endp file-names)))
  (let* ((root (dvc-tree-root))
         (normalized-file-names (xmtn--normalize-file-names root file-names))
         (msg (case (length file-names)
                (1 (format "%s" (first normalized-file-names)))
                (t (format "%s files/directories"
                           (length normalized-file-names))))))
    ;; FIXME: confirm should be in upper level DVC code.
    (when (or (not dvc-confirm-ignore)
              (y-or-n-p (format "Ignore %s in monotone tree %s? " msg root)))
      (xmtn--add-patterns-to-mtnignore
       root
       (let ((default-directory root))
         (mapcan (lambda (file-name)
                   (if (or (file-symlink-p file-name)
                           (xmtn--have-no-ignore)
                           (not (file-directory-p file-name)))
                       (list (xmtn--perl-regexp-for-file-name file-name))

                     ;; If mtn automate inventory doesn't support
                     ;; --no-ignore, it also recurses into unknown
                     ;; directories, so we need to ignore files in
                     ;; this directory as well as the directory
                     ;; itself.
                     (setq file-name (directory-file-name file-name))
                     (list
                      (xmtn--perl-regexp-for-file-name file-name)
                      (xmtn--perl-regexp-for-files-in-directory file-name))))
                 normalized-file-names))
       t))))

;;;###autoload
(defun xmtn-dvc-backend-ignore-file-extensions (extensions)
  (xmtn--add-patterns-to-mtnignore
   (dvc-tree-root)
   (mapcar #'xmtn--perl-regexp-for-extension extensions)
   t))

;;;###autoload
(defun xmtn-dvc-backend-ignore-file-extensions-in-dir (file-list)
  (xmtn--add-patterns-to-mtnignore
   (dvc-tree-root)
   (mapcar #'xmtn--perl-regexp-for-extension-in-dir file-list)
   t))

(defun xmtn--add-files (root file-names)
  (dolist (file-name file-names)
    ;; I don't know how mtn handles symlinks (and symlinks to
    ;; directories), so forbid them for now.
    (assert (not (file-symlink-p file-name))))
  (setq file-names (xmtn--normalize-file-names root file-names))
  (xmtn--run-command-sync root
                          `("add" "--" ,@file-names)))

;;;###autoload
(defun xmtn-dvc-add-files (&rest files)
  (xmtn--add-files (dvc-tree-root) files))

;; Appears redundant, given that there is `xmtn-dvc-add-files'.  But
;; it's part of the DVC API.  FIXME.
;;;###autoload
(defun xmtn-dvc-add (file)
  (xmtn--add-files (dvc-tree-root) (list file)))

(defun xmtn--do-remove (root file-names do-not-execute)
  (xmtn--run-command-sync
   root `("drop"
          ,@(if do-not-execute `("--bookkeep-only") `())
          "--" ,@(xmtn--normalize-file-names root file-names)))
  ;; return t to indicate we succeeded
  t)

;;;###autoload
(defun xmtn-dvc-remove-files (&rest files)
  (xmtn--do-remove (dvc-tree-root) files nil))

;;;###autoload
(defun xmtn-dvc-rename (from-name to-name bookkeep-only)
  ;; See `dvc-rename' for doc string.
  (let ((root (dvc-tree-root)))
    (let ((to-normalized-name (xmtn--normalize-file-name root to-name))
          (from-normalized-name (xmtn--normalize-file-name root from-name)))
      (xmtn--run-command-sync
       root `("rename"
              ,@(if bookkeep-only `("--bookkeep-only") `())
              "--" ,from-normalized-name ,to-normalized-name))))
  ;; FIXME: We should do something analogous to
  ;; `dvc-revert-some-buffers' (but for renaming) here.  But DVC
  ;; doesn't provide a function for that.
  )

(defun xmtn--insert-hint-into-process-buffer (string)
  (let ((inhibit-read-only t)
        deactivate-mark)
    (save-excursion
      (let ((start (point)))
        (insert string)
        (let ((end (1- (point))))
          (add-text-properties start end '(face (:slant italic))))))))

(defun xmtn--run-command-that-might-invoke-merger (root command post-process)
  ;; Run async, not sync; it might recursively invoke emacsclient for
  ;; merging; and we might need to send an enter keystroke when
  ;; finished.
  (lexical-let ((post-process post-process))
    (xmtn--run-command-async
     root command
     :finished
     (lambda (output error status arguments)
       (with-current-buffer output
         (save-excursion
           (goto-char (point-max))
           (xmtn--insert-hint-into-process-buffer "[process finished]\n")))
       (if post-process
           (funcall post-process)))
     :error
     (lambda (output error status arguments)
       (with-current-buffer output
         (save-excursion
           (goto-char (point-max))
           (xmtn--insert-hint-into-process-buffer
            "[process terminated with an error]\n")
           (dvc-show-error-buffer error))))))
  ;; Show process buffer.  Monotone might spawn an external merger and
  ;; ask the user to hit enter when finished.
  (dvc-show-process-buffer)
  (goto-char (point-min))
  (xmtn--insert-hint-into-process-buffer
   (substitute-command-keys
    (concat
     "This buffer will show the output of the mtn subprocess, if any."
     "\nTo send an \"enter\" keystroke to mtn, use"
     " \\[xmtn-send-enter-to-subprocess]"
     "\nin this buffer.  This might be necessary"
     " if mtn launches an external merger."
     "\nWhen mtn has finished, just bury this buffer, or kill it."
     "\n")))
  (goto-char (point-max))
  ;; I don't think DVC's process filter can deal with read-only
  ;; buffers yet.
  ;;(setq buffer-read-only t)
  )

;;;###autoload
(defun xmtn-send-enter-to-subprocess ()
  "Send an \"enter\" keystroke to a monotone subprocess.

To be used in an xmtn process buffer.  Useful when monotone
spawns an external merger and asks you to hit enter when
finished."
  (interactive)
  (let ((process (loop for (process nil) in dvc-process-running
                       when (eql (current-buffer) (process-buffer process))
                       return process)))
    (unless process
      (error "No active process for buffer %s found" (current-buffer)))
    (process-send-string process "\n")
    (save-excursion
      (goto-char (point-max))
      (xmtn--insert-hint-into-process-buffer "[sent enter keystroke]\n"))))

;;; It's kind of a wart that these "xmtn--do-<operation>" functions
;;; don't have the same contract with respect to
;;; synchronousness/asynchronousness, progress messages and return
;;; value.

(defun xmtn--do-explicit-merge (root left-revision-hash-id right-revision-hash-id
                                     destination-branch-name)
  (check-type root string)
  (check-type left-revision-hash-id xmtn--hash-id)
  (check-type right-revision-hash-id xmtn--hash-id)
  (check-type destination-branch-name string)
  (xmtn--run-command-that-might-invoke-merger root
                                              `("explicit_merge"
                                                "--"
                                                ,left-revision-hash-id
                                                ,right-revision-hash-id
                                                ,destination-branch-name)
                                              nil)
  nil)

(defun xmtn--do-update (root target-revision-hash-id post-update-p)
  (check-type root string)
  (check-type target-revision-hash-id xmtn--hash-id)
  (lexical-let ((progress-message (format "Updating tree %s to revision %s"
                                          root target-revision-hash-id))
                (post-update-p post-update-p))
    (let ((command `("update" "--move-conflicting-paths" ,(concat "--revision=" target-revision-hash-id)))
          (post-process
           (lambda ()
             (message "%s... done" progress-message)
             (if post-update-p
                 (progn
                   (dvc-revert-some-buffers default-directory)
                   (dvc-diff-clear-buffers 'xmtn
                                           default-directory
                                           "* Just updated; please refresh buffer"
                                           (xmtn--status-header
                                            default-directory
                                            (xmtn--get-base-revision-hash-id-or-null default-directory)))))))
          )

      (message "%s..." progress-message)
      ;; this used to have an option to call '--might-invoke-merger'; could be simplified.
      (xmtn--run-command-sync root command)
      (funcall post-process))
    nil))

(defun xmtn--update (root target-revision-hash-id check-id-p no-ding)
  ;; mtn will just give an innocuous message if already updated, which
  ;; the user won't see. So check that here - it's fast.
  ;; Don't throw an error; upper level might be doing other directories as well.
  (if (and check-id-p
           (equal (xmtn--get-base-revision-hash-id root) target-revision-hash-id))
      (progn
        (unless no-ding (ding))
        (message "Tree %s is already based on target revision %s"
                 root target-revision-hash-id))
    (dvc-save-some-buffers root)
    (xmtn--do-update root target-revision-hash-id check-id-p)))

;;;###autoload
(defun xmtn-dvc-update (&optional revision-id no-ding)
  (let ((root (dvc-tree-root)))
    (if revision-id
        (xmtn--update root (xmtn--revision-hash-id revision-id) t no-ding)

      (let* ((branch (xmtn--tree-default-branch root))
             (heads (xmtn--heads root branch)))
        (case (length heads)
          (0 (assert nil))
          (1
           (xmtn--update root (first heads) t no-ding))

          (t
           ;; User can choose one head from a revlist, or merge them.
           (error (substitute-command-keys
                   (concat "Branch %s is unmerged (%s heads)."
                           "  Try \\[xmtn-view-heads-revlist] and \\[dvc-merge] or \\[dvc-revlist-update]"))
                  branch (length heads)))))))
  nil)

(defun xmtn-propagate-from (other &optional cached-branch)
  "Propagate from OTHER branch to local tree branch."
  (interactive "MPropagate from branch: ")
  (let*
      ((root (dvc-tree-root))
       (local-branch (or cached-branch
                         (xmtn--tree-default-branch root)))
       (resolve-conflicts
        (if (file-exists-p (concat root "/_MTN/conflicts"))
            (progn
              "--resolve-conflicts-file=_MTN/conflicts")))
       (cmd (list "propagate" other local-branch resolve-conflicts
                  (xmtn-dvc-log-message)))
       (prompt
        (if resolve-conflicts
            (concat "Propagate from " other " to " local-branch " resolving conflicts? ")
          (concat "Propagate from " other " to " local-branch "? "))))

    (save-some-buffers t); conflicts file may be open.

    (if xmtn-confirm-operation
        (if (not (yes-or-no-p prompt))
            (error "user abort")))

    (lexical-let
        ((display-buffer (current-buffer))
         (msg (mapconcat (lambda (item) item) cmd " ")))
      (message "%s..." msg)
      (if xmtn-confirm-operation
          (xmtn--run-command-that-might-invoke-merger
           root cmd
           (lambda ()
             (xmtn--refresh-status-header display-buffer)
             (message "%s... done" msg)))
        (xmtn--run-command-sync
           root cmd
           :finished (lambda (output error status arguments)
                       (xmtn--refresh-status-header display-buffer)
                       (message "%s... done" msg)))))))

(defun xmtn-dvc-merge-1 (root refresh-status)
  (lexical-let ((refresh-status refresh-status))
    (xmtn--run-command-async
     root
     (list
      "merge"
      (if (file-exists-p (concat root "/_MTN/conflicts"))
          "--resolve-conflicts-file=_MTN/conflicts")
      (xmtn-dvc-log-message))
     :finished (lambda (output error status arguments)
                 (if refresh-status
                     (xmtn--refresh-status-header (current-buffer)))))))

;;;###autoload
(defun xmtn-dvc-merge (&optional other)
  (if other
      (xmtn-propagate-from other)
    ;; else merge heads
    (let* ((root (dvc-tree-root))
           (branch (xmtn--tree-default-branch root))
           (heads (xmtn--heads root branch)))
      (case (length heads)
        (0 (assert nil))
        (1
         (message "already merged"))
        (t
         (xmtn-dvc-merge-1 root t)))))
  nil)

;;;###autoload
(defun xmtn-dvc-pull (&optional other)
  "Implement `dvc-pull' for xmtn."
  (lexical-let*
      ((root (dvc-tree-root))
       (name (concat "mtn pull " root)))
    (message "%s..." name)
    ;; mtn progress messages are put to stderr, and there is typically
    ;; nothing written to stdout from this command, so put both in the
    ;; same buffer.
    ;; FIXME: this output is not useful; need to use automation
    (xmtn--run-command-async root `("pull" ,other)
                             :output-buffer name
                             :error-buffer name
                             :finished
                             (lambda (output error status arguments)
                               (pop-to-buffer output)
                               (message "%s... done" name)))))

;;;###autoload
(defun xmtn-dvc-revert-files (&rest file-names)
  (when (stringp file-names) (setq file-names (list file-names)))
  (let ((root (dvc-tree-root)))
    (assert (not (endp file-names)))
    (dvc-save-some-buffers root)
    (let ((normalized-file-names (xmtn--normalize-file-names root file-names)))
      (lexical-let
          ((root root)
           (progress-message
            (if (eql (length file-names) 1)
                (format "Reverting file %s" (first file-names))
              (format "Reverting %s files" (length file-names)))))
        (message "%s..." progress-message)
        (xmtn--run-command-sync root `("revert" "--"
                                       ,@normalized-file-names)
                                :finished
                                (lambda (output error status arguments)
                                  (message "%s... done" progress-message)))
        (dvc-revert-some-buffers root))))
  nil)

;;;###autoload
(defun xmtn-revision-get-previous-revision (file revision-id)
  (xmtn--revision-get-file-helper file (list 'previous-revision (cadr revision-id))))

;;;###autoload
(defun xmtn-revision-get-last-revision (file stuff)
  (xmtn--revision-get-file-helper file `(last-revision ,@stuff)))

;;;###autoload
(defun xmtn-revision-get-file-revision (file stuff)
  (xmtn--revision-get-file-helper file `(revision ,@stuff)))

(defun xmtn--revision-get-file-helper (file backend-id)
  "Fill current buffer with the contents of FILE revision BACKEND-ID."
  (let ((root (dvc-tree-root)))
    (let* ((normalized-file (xmtn--normalize-file-name root file))
           (corresponding-file
            (xmtn--get-corresponding-path root normalized-file
                                          `(local-tree ,root) backend-id)))
      (if (null corresponding-file)
          ;; File doesn't exist.  Since this function is (as far
          ;; as I know) only called from diff-like functions, a
          ;; missing file is not an error but just means the diff
          ;; should be computed against an empty file.  So just
          ;; leave the buffer empty.
          (progn)
        (let ((temp-dir nil))
          (unwind-protect
              (progn
                (setq temp-dir (make-temp-file
                                "xmtn--revision-get-file-" t))
                ;; Going through a temporary file and using
                ;; `insert-file-contents' in conjunction with as
                ;; much of the original file name as possible seems
                ;; to be the best way to make sure that Emacs'
                ;; entire file coding system detection logic is
                ;; applied.  Functions like
                ;; `find-operation-coding-system' and
                ;; `find-file-name-handler' are not a complete
                ;; replacement since they don't look at the contents
                ;; at all.
                (let ((temp-file (concat temp-dir "/" corresponding-file)))
                  (make-directory (file-name-directory temp-file) t)
                  (with-temp-file temp-file
                    (set-buffer-multibyte nil)
                    (setq buffer-file-coding-system 'binary)
                    (xmtn--insert-file-contents-by-name root backend-id corresponding-file (current-buffer)))
                  (let ((output-buffer (current-buffer)))
                    (with-temp-buffer
                      (insert-file-contents temp-file)
                      (let ((input-buffer (current-buffer)))
                        (with-current-buffer output-buffer
                          (insert-buffer-substring input-buffer)))))))
            (when temp-dir
              (dvc-delete-recursively temp-dir))))))))

(defun xmtn--get-file-by-id (root file-id save-as)
  "Store contents of FILE-ID in file SAVE-AS."
  (with-temp-file save-as
    (set-buffer-multibyte nil)
    (setq buffer-file-coding-system 'binary)
    (xmtn--insert-file-contents root file-id (current-buffer))))

(defun xmtn--revision-parents (root revision-hash-id)
  (xmtn-automate-simple-command-output-lines root
                                             `("parents" ,revision-hash-id)))

(defun xmtn--get-content-changed (root backend-id normalized-file)
  (xmtn-match (xmtn--resolve-backend-id root backend-id)
    ((local-tree $path) (error "Not implemented"))
    ((revision $revision-hash-id)
     (xmtn--with-automate-command-output-basic-io-parser
         (parser root `("get_content_changed" ,revision-hash-id
                        ,normalized-file))
       (loop for stanza = (funcall parser)
             while stanza
             collect (xmtn-match stanza
                       ((("content_mark" (id $previous-id)))
                        previous-id)))))))

(defun xmtn--limit-length (list n)
  (or (null n) (<= (length list) n)))

(defun xmtn--close-set (fn initial-set last-n)
  (let ((new-elements initial-set)
        (current-set nil))
    (while (and new-elements (xmtn--limit-length current-set last-n))
      (let ((temp-elements nil)
            (next-elements nil)
            (new-element nil))
        (while new-elements
          (setq new-element (car new-elements))
          (setq temp-elements (funcall fn new-element))
          (setq current-set (append (set-difference temp-elements current-set :test #'equal) current-set))
          (setq next-elements (append temp-elements next-elements))
          (setq new-elements (cdr new-elements)))
        (setq new-elements next-elements)))
    current-set))

(defun xmtn--get-content-changed-closure (root backend-id normalized-file last-n)
  (lexical-let ((root root))
    (labels ((changed-self-or-ancestors (entry)
               (destructuring-bind (hash-id file-name) entry
                 (check-type file-name string)
                 ;; get-content-changed can return one or two revisions
                 (loop for next-change-id in (xmtn--get-content-changed
                                              root `(revision ,hash-id)
                                              file-name)
                       for corresponding-path =
                       (xmtn--get-corresponding-path-raw root file-name
                                                         hash-id next-change-id)
                       when corresponding-path
                       collect `(,next-change-id ,corresponding-path))))
             (changed-proper-ancestors (entry)
                                       (destructuring-bind (hash-id file-name) entry
                                         (check-type file-name string)
                                         ;; revision-parents can return one or two revisions
                                         (loop for parent-id in (xmtn--revision-parents root hash-id)
                                               for path-in-parent =
                                               (xmtn--get-corresponding-path-raw root file-name
                                                                                 hash-id parent-id)
                                               when path-in-parent
                                               append (changed-self-or-ancestors
                                                       `(,parent-id ,path-in-parent))))))
      (xmtn--close-set
       #'changed-proper-ancestors
       (xmtn-match (xmtn--resolve-backend-id root backend-id)
         ((local-tree $path) (error "Not implemented"))
         ((revision $id) (changed-self-or-ancestors
                          `(,id ,normalized-file))))
       last-n))))

(defun xmtn--get-corresponding-path-raw (root normalized-file-name
                                              source-revision-hash-id
                                              target-revision-hash-id)
  (check-type normalized-file-name string)
  (xmtn--with-automate-command-output-basic-io-parser
      (next-stanza root `("get_corresponding_path"
                          ,source-revision-hash-id
                          ,normalized-file-name
                          ,target-revision-hash-id))
    (xmtn-match (funcall next-stanza)
      (nil nil)
      ((("file" (string $result)))
       (assert (null (funcall next-stanza)))
       result))))


(defun xmtn--get-corresponding-path (root normalized-file-name
                                          source-revision-backend-id
                                          target-revision-backend-id)
  (block get-corresponding-path
    (let (source-revision-hash-id
          target-revision-hash-id
          (file-name-postprocessor #'identity))
      (let ((resolved-source-revision
             (xmtn--resolve-backend-id root source-revision-backend-id))
            (resolved-target-revision
             (xmtn--resolve-backend-id root target-revision-backend-id)))
        (xmtn-match resolved-source-revision
          ((revision $hash-id)
           (setq source-revision-hash-id hash-id))
          ((local-tree $path)
           (assert (xmtn--same-tree-p root path))
           (let ((base-revision-hash-id
                  (xmtn--get-base-revision-hash-id-or-null path)))
             (if (null base-revision-hash-id)
                 (xmtn-match resolved-target-revision
                   ((revision $hash-id)
                    (return-from get-corresponding-path nil))
                   ((local-tree $target-path)
                    (assert (xmtn--same-tree-p path target-path))
                    (return-from get-corresponding-path normalized-file-name)))
               (setq normalized-file-name (xmtn--get-rename-in-workspace-to
                                           path normalized-file-name))
               (setq source-revision-hash-id base-revision-hash-id)))))
        (xmtn-match resolved-target-revision
          ((revision $hash-id)
           (setq target-revision-hash-id hash-id))
          ((local-tree $path)
           (assert (xmtn--same-tree-p root path))
           (let ((base-revision-hash-id
                  (xmtn--get-base-revision-hash-id-or-null path)))
             (if (null base-revision-hash-id)
                 (return-from get-corresponding-path nil)
               (setq target-revision-hash-id base-revision-hash-id
                     file-name-postprocessor
                     (lexical-let ((path path))
                       (lambda (file-name)
                         (xmtn--get-rename-in-workspace-from path
                                                             file-name)))))))))
      (let ((result
             (xmtn--get-corresponding-path-raw root normalized-file-name
                                               source-revision-hash-id
                                               target-revision-hash-id)))
        (if (null result)
            nil
          (funcall file-name-postprocessor result))))))

(defun xmtn--get-rename-in-workspace-from (root normalized-source-file-name)
  ;; FIXME: need a better way to implement this
  (check-type normalized-source-file-name string)
  (block parse
    (xmtn--with-automate-command-output-basic-io-parser
        (parser root `("inventory"))
      (xmtn--parse-inventory parser
                             (lambda (path status changes old-path new-path
                                           old-type new-type fs-type)
                               (when (equal normalized-source-file-name
                                            old-path)
                                 (return-from parse
                                   path)))))
    normalized-source-file-name))

(defun xmtn--get-rename-in-workspace-to (root normalized-target-file-name)
  ;; FIXME: need a better way to implement this
  (check-type normalized-target-file-name string)
  (block parse
    (xmtn--with-automate-command-output-basic-io-parser
        (parser root `("inventory" ,normalized-target-file-name))
      (xmtn--parse-inventory parser
                             (lambda (path status changes old-path new-path
                                           old-type new-type fs-type)
                               (when (and old-path
                                          (equal normalized-target-file-name
                                                 path))
                                 (return-from parse
                                   old-path)))))
    normalized-target-file-name))

(defun xmtn--file-contents-as-string (root content-hash-id)
  (check-type content-hash-id xmtn--hash-id)
  (xmtn-automate-simple-command-output-string
   root `("get_file" ,content-hash-id)))

(defun xmtn--insert-file-contents (root content-hash-id buffer)
  (check-type content-hash-id xmtn--hash-id)
  (xmtn-automate-simple-command-output-insert-into-buffer
   root buffer `("get_file" ,content-hash-id)))

(defun xmtn--insert-file-contents-by-name (root backend-id normalized-file-name buffer)
  (let* ((resolved-id (xmtn--resolve-backend-id root backend-id))
         (hash-id (case (car resolved-id)
                    (local-tree nil)
                    (revision (cadr resolved-id))))
         (cmd (if hash-id
                  (cons (list "revision" hash-id) (list "get_file_of" normalized-file-name))
                (list "get_file_of" normalized-file-name))))
    (xmtn-automate-simple-command-output-insert-into-buffer root buffer cmd)))

(defun xmtn--same-tree-p (a b)
  (equal (file-truename a) (file-truename b)))

(defstruct (xmtn--revision (:constructor xmtn--make-revision))
  ;; matches data output by 'mtn diff'
  new-manifest-hash-id
  old-revision-hash-ids
  delete
  rename
  add-dir
  add-file
  patch-file
  clear-attr
  set-attr
  )

(defun xmtn--parse-partial-revision (parser)
  "Parse basic_io output from get_revision, starting with the old_revision stanzas."
  (let ((old-revision-hash-ids (list))
        (delete (list))
        (rename (list))
        (add-dir (list))
        (add-file (list))
        (patch-file (list))
        (clear-attr (list))
        (set-attr (list)))
    (flet ((decode-path (path)
             (decode-coding-string path 'xmtn--monotone-normal-form)))
      (loop for stanza = (funcall parser)
            while stanza
            do
            (xmtn-match stanza
              ;; Most common case, "patch", first.
              ((("patch" (string $filename))
                ("from" (id $from-id))
                ("to" (id $to-id)))
               (push `(,(decode-path filename) ,from-id ,to-id)
                     patch-file))
              ((("old_revision" (null-id)))
               ;; Why doesn't mtn just skip this stanza?
               )
              ((("old_revision" (id $hash-id)))
               (push hash-id old-revision-hash-ids))
              ((("delete" (string $path)))
               (push `(,(decode-path path)) delete))
              ((("rename" (string $from-path))
                ("to" (string $to-path)))
               (push `(,(decode-path from-path) ,(decode-path to-path))
                     rename))
              ((("add_dir" (string $path)))
               (push `(,(decode-path path)) add-dir))
              ((("add_file" (string $path))
                ("content" (id $file-id)))
               (push `(,(decode-path path) ,file-id)
                     add-file))
              ;; "patch": See above.
              ((("clear" (string $path))
                ("attr" (string $attr-name)))
               (push `(,(decode-path path) ,attr-name)
                     clear-attr))
              ((("set" (string $path))
                ("attr" (string $attr-name))
                ("value" (string $attr-value)))
               (push `(,(decode-path path) ,attr-name ,attr-value)
                     set-attr)))))
    (setq old-revision-hash-ids (nreverse old-revision-hash-ids)
          delete (nreverse delete)
          rename (nreverse rename)
          add-dir (nreverse add-dir)
          add-file (nreverse add-file)
          patch-file (nreverse patch-file)
          clear-attr (nreverse clear-attr)
          set-attr (nreverse set-attr))
    (xmtn--make-revision
     :old-revision-hash-ids old-revision-hash-ids
     :delete delete
     :rename rename
     :add-dir add-dir
     :add-file add-file
     :patch-file patch-file
     :clear-attr clear-attr
     :set-attr set-attr
     )))


;;;###autoload
(defun xmtn-dvc-revision-nth-ancestor (&rest args)
  ;; There is a reasonable default implementation to fall back on.  It
  ;; will just call `xmtn-dvc-revision-direct-ancestor' N times.  We
  ;; can't do any better than linear-time anyway, since we have to
  ;; chase the ancestry links (and check the uniqueness at each step).
  (apply #'dvc-dvc-revision-nth-ancestor args))

(defalias 'xmtn-dvc-revlist 'xmtn-view-heads-revlist)

(provide 'xmtn-dvc)

;;; xmtn-dvc.el ends here
