#|
RCSIF - Revision Control Interface

Written by Ron Garret, released into the public domain.

16 February 2010 -- Initial version
20 Feb 2010 -- Bug fix: make sure snapshots branch exists!

RCSIF is an attempt to integrate a revision control system (in this case, GIT) into
the CCL IDE.  This is a very preliminary first draft, more of a proof of concept than
a finished product.  It provides only the ability to take a snapshot of a single
file and then roll back to an earlier snapshot.  Snapshots are stored in a completely
separate branch called "snapshots" which does not share a common ancestor with any
other branch.  This is to prevent RCSIF from screwing up a live git repository.
You can always get rid of everything that RCSIF has done by simply deleting the
snapshots branch.

Quick start:

RCSIF works through the Hemlock text view context menu.  To use it, just load the
code, right-click on an editor window, and select "SNAPSHOT".  Then you can select
"ROLLBACK" to go back to earlier snapshots.  NOTE: the file you want to snapshot
MUST be in a git repository.  RCSIF will not create a repository for you.  So if you
try to snapshot or roll back a file that is not in a repository, CCL will dump an
error to the AltConsole and hang.  You can recover from this by typing ":pop" into
the AltConsole.

Needless to say, you will need to have git installed to ue RCSIF.

Design notes:

There are a number of things that make integrating Git with the CCL IDE quite
tricky.  Git makes some workflow assumptions that may not be true when using an
IDE.  For example, Git assumes that when you execute a "git commit" that your
current working directory is within the git repository to which you are committing.
This may not (and in fact very likely is not) the case when using the IDE.  You may,
for example, be editing two different files from two different repositories at the
same time.  So every time you do an operation, RCSIF has to set up a complete
environment for git to work in.  This is done via the WITH-GIT-PATH and WITH-GIT-BRANCH
macros.

As mentioned above, this code is experimental.  All suggestions on how to improve it
are welcome.
|#

(require :rg-utils)

; Edit this as needed for your environment
(setenv "PATH" "/usr/local/bin:/usr/bin:/bin:/usr/sbin:/sbin")

; Slightly saner interface to hemlock variables. RCSIF uses a hemlock variable to
; keep track of which version a file has been rolled back to.
(defmacro defbufvar (buf var &optional (docstring ""))
  `(hi:defhvar (format nil "~A" ',var) ,docstring :buffer ,buf))

(defmacro bufvar (buf var)
  `(hi::variable-value ',(hi:string-to-variable (format nil "~A" var)) :buffer ,buf))

; Make documents print themselves out in a more informative way
(define-print-method (GUI::HEMLOCK-EDITOR-DOCUMENT) "#<Hemlock document ~A>"
  (if (%null-ptr-p (slot-value self 'GUI::TEXTSTORAGE)) "<CLOSED>" (document-path self)))

(defun find-window (name)
  "Find the first window whose name begins with NAME.  Returns a hemlock frame,
  not an NSWindow.  So it really ought to be called find-hemlock-frame.  But then
  gui::windows really ought to be called gui::hemlock-frames.  Oh well."
  (dolist (w (gui::windows))
    (if (and (#/isVisible w)
             (let ((s (ccl::lisp-string-from-nsstring (#/title w))))
               (and (>= (length s) (length name))
                    (string-equal name s :end2 (length name)))))
      (return-from find-window w))))

; There are a bazillion different classes in play in the IDE.  The following functions
; convert back and forth between some of the more common ones.
(defun hemlock-frame-for-view (hv)
  (slot-value (slot-value hv 'hi::pane) 'ns:_window))

(defun hemlock-view-for-frame (hf)
  (gui::front-view-for-buffer (gui::hemlock-buffer hf)))

(defun hemlock-view-for-file (path)
  (gui::cocoa-edit path))

(defun hemlock-document-for-frame (hf)
  (hi::buffer-document (gui::hemlock-buffer hf)))

; Some miscellaneous utility functions
(defun document-path (doc)
  (CCL::LISP-STRING-FROM-NSSTRING (#/path (#/fileURL doc))))

(defun document-text (doc)
  (let* ((b (gui::hemlock-buffer doc))
         (r (hi::buffer-region b)))
    (let ((hi::*current-buffer* b))
      (hi::region-to-string r))))

(defun reset-path (doc)
  "Reset the file's path so that you can save it without having Cocoa complain about
  the file having been moved or renamed."
  (#/setFileURL: doc (#/fileURL doc)))

(defun revert (doc)
  (hemlock-ext:revert-hemlock-buffer (gui::hemlock-buffer doc))
  (reset-path doc)
  (gui::save-hemlock-document doc))

; The interface to git
(defun git (cmd &rest args)
  (bb :mv (result code) (system "sh" (format nil "git ~?" cmd args))
      (if (<= 0 code 1) (values result code) (error "GIT error: ~A" result))))

; These functions aren't actually used at the moment, but they could be handy
; some day.
(define-method (git-store (s string))
  (system "git hash-object --stdin -w" s))

(define-method (git-store (doc GUI::HEMLOCK-EDITOR-DOCUMENT))
  (git-store (document-text doc)))

(defun git-retrieve (hash)
  (git "cat-file blob ~A" hash))

; The actual RCSIF code starts here
(defun branches ()
  (bb branches (butlast (split (git "branch") #\newline))
      current-branch (find #\* branches :key (fn (s) (elt s 0)))
      branches (cons current-branch (remove current-branch branches))
      (collect (and x (subseq x 2)) for x in branches)))

(defun current-branch () (first (branches)))

(defun set-branch (branch)
  (git "symbolic-ref HEAD 'refs/heads/~A'" branch)
  (git "read-tree HEAD"))

(defun delete-branch (branch)
  (git "branch -D '~A'" branch))

(defun ls-index ()
  (git "ls-files --stage"))

(defun empty-index ()
  (unless (zerop (length (ls-index)))
    (git "rm --cached -f -r .")))

(defun create-empty-branch (name &optional (commit-message "Empty branch"))
  (let ((b0 (current-branch)))
    (unwind-protect
        (progn
          (git "symbolic-ref HEAD 'refs/heads/~A'" name)
          (empty-index)
          (git "commit --allow-empty -m '~A'" commit-message))
      (set-branch b0))))

(defun insure-branch (branch)
  (unless (member branch (branches) :test 'string=)
    (create-empty-branch branch)))

(defmacro with-git-branch (branch &body body)
  (with-gensyms (old-branch)
    `(let ((,old-branch (current-branch)))
       (insure-branch ,branch)
       (unwind-protect
           (progn
             (set-branch ,branch)
             ,@body)
         (set-branch ,old-branch)))))

(defmacro with-snapshot-branch (&body body)
  `(with-git-branch "snapshots" ,@body))

(defmacro with-git-path ((var path) &body body)
  (with-gensyms (pathvar oldpath n)
    `(let ((,oldpath (mac-default-directory)) (,pathvar ,path))
       (unwind-protect
           (let ((,n (position #\/ ,pathvar :from-end t)))
             (cwd (subseq ,pathvar 0 ,n))
             (let ((,var (subseq ,pathvar (1+ ,n))))
               ,@body))
         (cwd ,oldpath)))))

(defun snapshot (doc)
  (gui::save-hemlock-document doc)
  (with-git-path (p (document-path doc))
    (with-snapshot-branch
      (git "add '~A'" p)
      (git "commit -m 'Snapshot ~A'" p)))
  (let ((b (gui::hemlock-buffer doc)))
    (defbufvar b rollback-version)
    (setf (bufvar b rollback-version) nil)))

(defun next-revs-for-file (filename &optional (n 3) (rev "snapshots"))
  (with-git-path (p filename)
    (insure-branch "snapshots")
    (collect (split _ #\Space) for _ in
      (butlast (split (git "rev-list -n ~A --timestamp ~A -- '~A'" n rev p)
                      #\Newline)))))

(define-method (recent-revs (doc GUI::HEMLOCK-EDITOR-DOCUMENT)
                            &optional (n 3) (rev "snapshots"))
  (next-revs-for-file (document-path doc) n rev))

(defun next-rev-for-file (filename &optional rev)
  (second (next-revs-for-file filename 3 (or rev "snapshots"))))

(defun current-rev (doc)
  (let ((b (gui::hemlock-buffer doc)))
    (defbufvar b rollback-version)
    (bufvar b rollback-version)))

(define-method (next-rev (doc GUI::HEMLOCK-EDITOR-DOCUMENT))
  (next-rev-for-file (document-path doc) (current-rev doc)))

(defun file-id-in-rev (filename rev)
  (with-git-path (p filename)
    (subseq (git "ls-tree ~A '~A'" rev p) 12 52)))

(defun file-contents-in-rev (filename rev)
  (with-git-path (p filename)
    (git-retrieve (file-id-in-rev filename rev))))

(defun rev-parents (rev)
  (butlast (split (git "cat-file commit ~A | grep ^parent" rev) #\newline)))

(defun pprint-unix-time (unix-time)
  (bb :mv (s m h d mo y) (decode-universal-time (+ unix-time CCL::UNIX-TO-UNIVERSAL-TIME))
      (format nil "~A/~A/~A ~A:~2,'0D:~2,'0D" mo d y h m s)))

(defun unsaved-rollback-alert ()
  (let ((alert (make-instance 'ns:ns-alert)))
    (#/setMessageText: alert #@"WARNING: This document has unsaved changes.")
    (#/addButtonWithTitle: alert #@"Cancel")
    (#/addButtonWithTitle: alert #@"Discard changes")
    (#/addButtonWithTitle: alert #@"Snapshot")
    (#/addButtonWithTitle: alert #@"Save")
    alert))

(objc:defmethod #/alertDidEnd:returnCode:contextInfo:
                ((self gui::hemlock-frame) alert (return-code integer) rev-item)
  (declare (ignore alert))
  (bb doc (hi::buffer-document (gui::hemlock-buffer (#/target rev-item)))
      action (elt #(:cancel :discard :snapshot :save)
                  (- return-code #$NSAlertFirstButtonReturn))
      (case action
        (:cancel)
        (:discard (#/updateChangeCount: doc #$NSChangeCleared) (rollback doc self rev-item))
        (:snapshot (snapshot doc) (rollback doc self rev-item))
        (:save (gui::save-hemlock-document doc) (rollback doc self rev-item))
        ))
  (%null-ptr))    ; Should not be needed, but it is.

(defun rollback (doc w rev-item)
  (if (#/isDocumentEdited doc)
    (#/beginSheetModalForWindow:modalDelegate:didEndSelector:contextInfo:
     (unsaved-rollback-alert)
     w w (objc:@selector #/alertDidEnd:returnCode:contextInfo:) rev-item)
    (bb buffer (gui::hemlock-buffer doc)
        revcnt (#/tag rev-item)
        rev (2nd (nth (1- revcnt) (recent-revs doc revcnt)))
        (gui::replace-document-text doc (file-contents-in-rev (document-path doc) rev))
        (setf (bufvar buffer rollback-version) rev))))

(defun cocoa-edit (&optional path)
  (if (and path (not (probe-file path))) (error "No such file: ~A" path))
  (gui::cocoa-edit path))

(objc:defmethod (#/snapshot: :void) ((self gui::hemlock-text-view) sender)
  (declare (ignore sender))
  (snapshot (hi::buffer-document (gui::hemlock-buffer self))))

(objc:defmethod (#/rollback: :void) ((self gui::hemlock-text-view) sender)
  (rollback (hi::buffer-document (gui::hemlock-buffer self))
            (hemlock-frame-for-view (gui::hemlock-view self))
            sender))

(defun reset-text-view-context-menu ()
  (bb m gui::*text-view-context-menu*
      (setf gui::*text-view-context-menu* nil)
      (#/release m)
      (gui::text-view-context-menu)))

(defun insure-snapshot-rollback-items ()
  (when (%null-ptr-p (#/itemWithTitle: (gui::text-view-context-menu) #@"Snapshot"))
    (#/addItem: GUI::*TEXT-VIEW-CONTEXT-MENU* (#/separatorItem ns:ns-menu-item))
    (#/addItemWithTitle:action:keyEquivalent:
     GUI::*TEXT-VIEW-CONTEXT-MENU* #@"Snapshot" (objc:@selector #/snapshot:) #@"")
    (#/addItemWithTitle:action:keyEquivalent:
     GUI::*TEXT-VIEW-CONTEXT-MENU* #@"Rollback" (%null-ptr) #@"")))

(defun rev-description (doc rev)
  (bb :db (timestamp rev) rev
      timestamp (pprint-unix-time (parse-integer timestamp))
      (if (equal rev (current-rev doc)) (strcat timestamp #\Space #\U+21D0) timestamp)))

(objc:defmethod #/menu ((self gui::hemlock-text-view))
  (insure-snapshot-rollback-items)
  (bb doc (hi::buffer-document (gui::hemlock-buffer self))
      revs (recent-revs doc 10)
      main-menu (gui::text-view-context-menu)
      rollback-submenu (make-instance 'ns:ns-menu :with-title #@"Rollback")
      rollback-item (#/itemWithTitle: main-menu #@"Rollback")
      (if (null revs)
        (#/addItemWithTitle:action:keyEquivalent:
         rollback-submenu (ccl::%make-nsstring "<No snapshots>") (%null-ptr) #@"")
        (for (rev cnt) in (zip revs (counter 1)) do
          (bb item (#/addItemWithTitle:action:keyEquivalent:
                    rollback-submenu
                    (ccl::%make-nsstring (rev-description doc rev))
                    (objc:@selector #/rollback:) #@"")
              (#/setTarget: item self)
              (#/setTag: item cnt))))
      (#/setSubmenu:forItem: main-menu rollback-submenu rollback-item)
      main-menu))

; Yech!  There really ought to be a less crufty way to do this
(in-package :gui)
(defun replace-document-text (doc str)
  (easygui::run-on-main-thread
   t
   (lambda()
     (assume-cocoa-thread)
     (let* (;(encoding (slot-value self 'encoding))
            (nsstring (ccl::%make-nsstring str))
            (buffer (hemlock-buffer doc))
            (old-length (hemlock-buffer-length buffer))
            (hi::*current-buffer* buffer)
            (textstorage (slot-value doc 'textstorage))
            (point (hi::buffer-point buffer))
            (pointpos (hi:mark-absolute-position point)))
       (hemlock-ext:invoke-modifying-buffer-storage
        buffer
        (lambda ()
          (#/edited:range:changeInLength:
           textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 old-length) (- old-length))
          (nsstring-to-buffer nsstring buffer)
          (let* ((newlen (hemlock-buffer-length buffer)))
            (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedAttributes (ns:make-ns-range 0 0) newlen)
            (#/edited:range:changeInLength: textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range 0 newlen) 0)
            (let* ((ts-string (#/hemlockString textstorage))
                   (display (hemlock-buffer-string-cache ts-string)))
              (reset-buffer-cache display) 
              (update-line-cache-for-index display 0)
              (move-hemlock-mark-to-absolute-position point
                                                      display
                                                      (min newlen pointpos))))
          (#/updateMirror textstorage)
          (setf (hi::buffer-modified buffer) nil)
          (hi::note-modeline-change buffer)))))))