;;; p4-view.el --- Major mode for editing client/branc view specifications

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

;;; Commentary:

;; When Perforce brings up a client/branch view, the buffer will be
;; automatically put in p4-view-mode.  Use C-c C-c to toggle it into and out
;; of a more human-readable state.

;;; Code:

(defcustom p4-view-auto-compress t
  "* If non-nil, automatically execute p4-view-toggle-compress
when a temp file that looks like a perforce branch or client view
is detected."
  :group 'p4
  :type 'boolean)

;;; ----------------------------------------------------------------------
;;; Internal variables
;;; ----------------------------------------------------------------------

;; quiet compiler warnings
(eval-when-compile
  (defvar map nil)
  (defvar font-lock-mode nil))

(defconst p4v-var-re ":\\(src\\|dst\\)\\(\\sw*\\)")

(defvar p4-view-mode-map nil)
(if p4-view-mode-map nil
  (let ((map (make-sparse-keymap)))
    (define-key map "\C-c\C-c" 'p4-view-toggle-compress)
    (setq p4-view-mode-map map)))

(defvar p4-view-font-lock-keywords
  '(
    ("^# \\(NOTE.*\\)" 1 'p4-highlight-face t)
    ("^[A-Za-z]+:" 0 font-lock-reference-face)
    ("^\\s-+\\(-\\)" 1 'p4-highlight-face)
    ;(":[sd=]..\\(\\sw+\\)" (1 font-lock-reference-face))
    (":src\\sw*/\\(.*\\)$" (1 font-lock-function-name-face))
    (":dst\\sw*/\\(.*\\)$" (1 font-lock-keyword-face))
    (":===\\sw*/\\(.*\\)$" (1 font-lock-type-face))
    ("/" (0 'default t))
    ))

;; Seems we need this to get comment hilighting to work.  Whatever.
(defvar p4-view-mode-syntax-table nil
  "Syntax table in use in view-mode buffers.")
(if p4-view-mode-syntax-table
    ()
  (setq p4-view-mode-syntax-table (make-syntax-table (standard-syntax-table)))
  (modify-syntax-entry ?\n ">" p4-view-mode-syntax-table)
  (modify-syntax-entry ?# "<" p4-view-mode-syntax-table))

(defun p4-view-mode ()
  "Major mode for manipulating client and branch views.

Use \\[p4-view-toggle-compress] to make a client/branch mapping view easier to read/edit.

Given a branch mapping line like the following, that command will:

   //depot/liberty/main/Jamfile //depot/liberty/project/solti/main/Janfile
   //depot/liberty/main/library/foo/myfile.c //depot/liberty/project/solti/main/library/fooo/myfile.c

- Read or infer a general source -> dest mapping rule, and use it to hide
  redundant path elements.  It also splits each view entry into two lines:

   :src/Jamfile
   :dst/Janfile
   :src/library/foo/myfile.c
   :dst/library/foo/myfile.c

- Further compress \"trivial\" mappings (like the one above), replacing
  the :src and :dst line with an equals sign \"===\".  Any mistakes or mapping
  variations show up clearly:

   :src/Jamfile
   :dst/Janfile
   :===/library/foo/myfile.c

Using \\[p4-view-toggle-compress] again will toggle the view back to normal,
as will saving the file.  You can have more than one <MAP> line."
  ;(interactive)
  (kill-all-local-variables)
  (set-syntax-table p4-view-mode-syntax-table)
  (set (make-local-variable 'comment-start-skip) "^#")
  (use-local-map p4-view-mode-map)
  (setq major-mode 'p4-view-mode)
  (setq mode-name "P4-view")
  (set (make-local-variable 'font-lock-defaults)
       '(p4-view-font-lock-keywords nil nil nil))
  (require 'font-lock)	;; because we use font-lock-verbose
  (let ((font-lock-verbose nil))
    (turn-on-font-lock))
  (add-hook 'write-contents-hooks
	    (lambda () (condition-case nil (p4-view-uncompress) (error nil)) nil))
  (if p4-view-auto-compress (p4-view-toggle-compress))
  (p4-view-insert-help-text)
  (message (substitute-command-keys
	    "Use \\[p4-view-toggle-compress] to toggle the view display.")))

(defun p4-view-insert-help-text ()
  ;; Insert some helpful text at the top of the buffer
  (save-excursion
    (goto-char (point-min))
    (while (and (not (eobp)) (looking-at "^#")) (forward-line 1))
    (or (bolp) (insert "\n"))
    (insert "#\n# NOTE: This buffer is in P4-view mode\n")
    (insert "# " (format "%s"
			 (substitute-command-keys
			  "\\[p4-view-toggle-compress] to toggle the view display.\n")))
    (set-buffer-modified-p nil)))
    
(defun p4-view-toggle-compress ()
  "See documentation for `p4-view-mode'."
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (re-search-forward "^View")
    (let ((case-fold-search nil))
      (if (re-search-forward (concat p4v-var-re "\\|:===") nil t)
	  (p4-view-uncompress)
	(p4-view-compress)))))

;;; ----------------------------------------------------------------------
;;; Utils
;;; ----------------------------------------------------------------------

(defmacro p4v-in-view (&rest forms)
  `(save-excursion
     (save-match-data
       (goto-char (point-min))
       (re-search-forward "^View")
       (forward-line 1)
       ,@forms)))
(put 'p4v-in-view 'lisp-indent-function 0)

(defun p4-view-compress ()
  (let* ((old-font-lock-mode (and (boundp 'font-lock-mode) font-lock-mode))
	 (map (p4v-get-map))
	 src dest)
    (and (featurep 'font-lock) (font-lock-mode -1))

    ;; Not really compression, but nice anyway
    (p4v-in-view
      (while (re-search-forward "^\t-" nil t) (replace-match "       -")))

    (while map
      (p4v-in-view
	(setq src (elt map 0) dest (elt map 1)
	      map (nthcdr 2 map))
	;; Replace variables, and replace intervening space with newline
	(while (re-search-forward
		(concat (cdr src) "\\(.*\\) \\(.*\\)" (cdr dest)) nil t)
	  (replace-match
	   (concat (car src) (match-string 1) "\n\t"
		   (match-string 2) (car dest)) t t))))

    (p4v-in-view
      ;; Replace trivial mappings
      (while (re-search-forward p4v-var-re nil t)
	(if (p4-vc-maps-are-equal)
	    (progn
	      (delete-region (progn (end-of-line) (point))
			     (progn (end-of-line 2) (point)))
	      (beginning-of-line)
	      (search-forward ":src") (replace-match ":===")))))

    (if old-font-lock-mode
	(let ((font-lock-verbose nil)) (turn-on-font-lock)))))

;; dynamic scope for `map'
(defun p4v-expand-var ()
  (beginning-of-line)
  (if (re-search-forward p4v-var-re (save-excursion (end-of-line) (point)) t)
      (let* ((var (format "%s" (match-string 0)))
	     (expansion (assoc var map)))
	(replace-match (cdr expansion))))
  (beginning-of-line))

(defun p4-view-uncompress ()
  (let* ((case-fold-search nil)
	 (old-font-lock-mode (and (boundp 'font-lock-mode) font-lock-mode))
	 (map (p4v-get-map))
	 src dest)
    (and (featurep 'font-lock) (font-lock-mode -1))

    ;; expand trivial mappings by duplicating line
    (p4v-in-view
      (while (re-search-forward ":===" nil t)
	(replace-match ":src")
	(beginning-of-line)
	(let ((tmp (buffer-substring (point) (progn (end-of-line) (point)))))
	  ;; Remove leading -, replace src with dst
	  (if (string-match "^\\s-*\\(-\\)" tmp)
	      (setq tmp (replace-match "" t t tmp 1)))
	  (if (string-match ":src" tmp)
	      (setq tmp (replace-match ":dst" t t tmp 0)))
	  (forward-line 1) (insert tmp "\n"))))

    ;; Now loop through and expand vars
    (p4v-in-view
      (while (re-search-forward p4v-var-re nil 'move)
	(p4v-expand-var)
	(end-of-line) (delete-char 1) (just-one-space)
	(p4v-expand-var)))

    (if old-font-lock-mode
	(let ((font-lock-verbose nil)) (turn-on-font-lock)))))

(defun p4-vc-maps-are-equal ()
  ;; return true if current and next line are identical except for :src/:dst
  (let (line1 line2)
    (save-excursion
      (beginning-of-line)
      (setq line1 (buffer-substring (point) (progn (end-of-line) (point))))
      (forward-line 1)
      (setq line2 (buffer-substring (point) (progn (end-of-line) (point))))
      ;; Chop leading ws and `-' char
      (if (string-match "^\\s-+-?" line1)
	  (setq line1 (replace-match "" t t line1 0)))
      (if (string-match ":src" line1)
	  (setq line1 (replace-match "&&&" t t line1)))
      (if (string-match "^\\s-+-?" line2)
	  (setq line2 (replace-match "" t t line2 0)))
      (if (string-match ":dst" line2)
	  (setq line2 (replace-match "&&&" t t line2)))
      (string-equal line1 line2))))

(defun p4v-get-map (&optional recursing)
  ;; Return alist mapping vars to expansions
  ;; The alist will always be of the form
  ;; ( (":srcXXX" . <str>) (":dstXXX" . <str>) ... )
  ;; Later <MAP> lines come earlier in the list, to give them higher
  ;; precedence.
  (let (map-alist (i 1))
    (save-match-data
      (save-excursion
	(goto-char (point-min))
	(while (re-search-forward "<MAP> \\(.*\\)" nil 'move)
	  (let ((elts (split-string (format "%s" (match-string 1))))
		varname src dest)
	    ;; no var name given -- push one on the list
	    (if (= (length elts) 2)
		(setq elts (cons (format "%s" (if (= i 1) "" i)) elts)
		      i (1+ i)))
	    (setq varname (elt elts 0)
		  src (elt elts 1)
		  dest (elt elts 2))
	    (setq map-alist
		  (nconc (list (cons (concat ":src" varname) src)
			       (cons (concat ":dst" varname) dest))
			 map-alist))))))

    (if (or recursing map-alist)
	map-alist
      (let ((infer (p4v-infer-map)))
	;; Save off the MAP line by stuffing it in the Description
	(goto-char (point-min))
	(re-search-forward "^Description:") (beginning-of-line)
	(while (not (looking-at "^\\s-*$")) (forward-line 1))
	(insert "\t<MAP> " (car infer) " " (cdr infer) "\n")
	(p4v-get-map 'recursing)))))

;; Use the first line of the view to infer a mapping.  If the src and dest
;; have one or more tail elements in common, we use the preceding elements
;; to form the general mapping rule.  Clever!
(defun p4v-infer-map ()
  ;; Find the first view line
  (p4v-in-view
    (or (looking-at "\t//\\([^/]+/.*\\) //\\(.*\\)")
	(error "Malformed view"))

    ;; Split it up and find common tail elements
    (let ((have-common-tail nil)
	  (src (format "%s" (match-string 1)))
	  (dest (format "%s" (match-string 2))))
      (setq src (nreverse (split-string src "/"))
	    dest (nreverse (split-string dest "/")))
      (while (and (car src)
		  (equal (car src) (car dest)))
	(setq have-common-tail t
	      src (cdr src)
	      dest (cdr dest)))
      (or have-common-tail (error "Can't figure out mapping"))

      ;; ... use the rest as the src/dest mapping
      (setq src (concat "//" (mapconcat 'identity (nreverse src) "/"))
	    dest (concat "//" (mapconcat 'identity (nreverse dest) "/")))
      (cons src dest))))

(provide 'p4-view)