don't create slices with multiple heads or initial commits

Author: mflatt

chop.rkt

@@ -48,13 +48,49 @@
       [drop-oldest?
        (define-values (commits head-commit commit->parents commit->children)
          (extract-commits))
+       
+       (define cs (hash-ref commit->children oldest-now))
+       (define new-initials (make-hash))
+       (let loop ([cs cs])
+         (for ([c (in-list cs)])
+           (define ps (remove oldest-now (hash-ref commit->parents c)))
+           (if (null? ps)
+               (hash-set! new-initials c #t)
+               (loop ps))))
+       (define new-root
+         (cond
+          [((hash-count new-initials) . > . 1)
+           ;; Dropping `oldest-now` might would multiple initial
+           ;; commits, which is potentially confusing (to `git-slice`
+           ;; itself, for example). Add an empty commit to serve
+           ;; as the root.
+           (printf "\n# Adding commit to serve as new initial commit\n")
+           (-system* git-exe "checkout" "--orphan" "newroot")
+           (-system* git-exe "rm" "-rf" ".")
+           (-system* git-exe "commit" "--allow-empty" "-m" "create slice")
+           (define new-root
+             (car
+              (filter-input (lambda (l)
+                              (cond
+                               [(regexp-match #rx"^commit (.*)$" l)
+                                => (lambda (m) (cadr m))]
+                               [else #f]))
+                            git-exe
+                            "log")))
+           (-system* git-exe "checkout" "master")
+           (-system* git-exe "branch" "-D" "newroot")
+           new-root]
+          [else #f]))
        (with-output-to-file ".git/info/grafts"
          (lambda ()
-           (for ([c (in-list (hash-ref commit->children oldest-now))])
+           (for ([c (in-list cs)])
              (displayln (apply ~a c
                                #:separator " "
-                               (remove oldest-now
-                                       (hash-ref commit->parents c)))))))]
+                               (let ([ps (remove oldest-now
+                                                 (hash-ref commit->parents c))])
+                                 (if new-root
+                                     (cons new-root ps)
+                                     ps)))))))]
       [else
        (with-output-to-file ".git/info/grafts"
          (lambda ()

compute.rkt

@@ -76,11 +76,11 @@
     (and lt
          (let ([old-start-commit (car lt)])
            (define m (member old-start-commit main-line-commits))
-           (unless m (error 'slide "start commit not found in main line: ~a" old-start-commit))
+           (unless m (error 'git-slice "start commit not found in main line: ~a" old-start-commit))
            (or (member start-commit m)
                (begin
                  (unless (member start-commit main-line-commits)
-                   (error 'slide "new start commit not found in main line: ~a" start-commit))
+                   (error 'git-slice "new start commit not found in main line: ~a" start-commit))
                  #f)))))
 
   ;; Determine the commit range that applies to a file.
@@ -116,11 +116,11 @@
                (lambda (m)
                  (define old-name (cadr m))
                  (unless (equal? old-name prev-name)
-                   (error 'slice (~a "confused by rename\n"
-                                     "  current: ~a\n"
-                                     "  from: ~a\n"
-                                     "  previous: ~a\n"
-                                     "  starting name: ~a")
+                   (error 'git-slice (~a "confused by rename\n"
+                                         "  current: ~a\n"
+                                         "  from: ~a\n"
+                                         "  previous: ~a\n"
+                                         "  starting name: ~a")
                           current-name
                           old-name
                           prev-name
@@ -195,6 +195,28 @@
   (define drop-oldest? (not (hash-ref relevants oldest-relevant #f)))
   (hash-set! relevants oldest-relevant #t)
 
+  (printf "Finding descendents of relevant commits\n")
+  (define commit->descendents (closure (hash-keys relevants) commit->children))
+  (define common-descendents
+    (apply set-intersect
+           (list->set (hash-keys relevants))
+           (for/list ([r (in-hash-keys relevants)])
+             (hash-ref commit->descendents r))))
+
+  (when (zero? (set-count common-descendents))
+    (printf "Adding new commit to serve as common descendant for new HEAD\n")
+    (-system* git-exe "commit" "--allow-empty" "-m" "merge slice")
+    (define new-root
+      (car
+       (filter-input (lambda (l)
+                       (cond
+                        [(regexp-match #rx"^commit (.*)$" l)
+                         => (lambda (m) (cadr m))]
+                        [else #f]))
+                     git-exe
+                     "log")))
+    (hash-set! relevants new-root #t))
+  
   (with-output-to-file (build-path dest-dir "relevants.rktd")
     #:exists exists-flag
     (lambda ()

git.rkt

@@ -4,7 +4,8 @@
          filter-input
          -system*
          -system*/print
-         extract-commits)
+         extract-commits
+         closure)
 
 (define git-exe (find-executable-path "git"))
 
@@ -49,4 +50,25 @@
                               [(c) (in-list v)])
       (hash-update ht c (lambda (p) (cons k p)) null)))
 
+  (let ([num-without-parents (for/sum ([v (in-hash-values commit->parents)])
+                               (if (null? v)
+                                   1
+                                   0))])
+    (unless (= 1 num-without-parents)
+      (error 'git-slice
+             "expect 1 initial commit, found ~a commits without parents"
+             num-without-parents)))
+  
   (values commits head-commit commit->parents commit->children))
+
+
+(define (closure start-commits commit->next)
+  (let ([ht (make-hash)])
+    (for ([start-commit (in-list start-commits)])
+      (let loop ([a start-commit])
+        (or (hash-ref ht a #f)
+            (let ([s (for/fold ([s (set a)]) ([p (in-list (hash-ref commit->next a null))])
+                       (set-union s (loop p)))])
+              (hash-set! ht a s)
+              s))))
+    ht))

tests/test.rkt

@@ -1,6 +1,7 @@
 #lang racket
 (require racket/runtime-path
-         rackunit)
+         rackunit
+         "../git.rkt")
 
 (define-runtime-module-path-index main "../main.rkt")
 
@@ -89,33 +90,61 @@
   ;; etc., and each of those directories corresponds to a slice to
   ;; try. Each `commit` names the end slices that should include
   ;; the commit.
+  ;;
+  ;; Gamma is created in one branch, and Delta in another
+  ;; Epsilon is created in two branches, which would give it
+  ;;  multiple initial commits without special handling
+  ;; Zeta has modifications in two branches, and none
+  ;;  after the branch
 
   (create "a/x_Alpha")
   (commit "Alpha")
+  
   (modify "a/x_Alpha")
   (create "a/y_Alpha")
   (commit "Alpha")
+  
   (create "b/x_Beta")
   (create "b/y_Beta")
   (commit "Beta")
+  
   (move "a/x_Alpha" "a/z_Alpha")
   (move "a/y_Alpha" "c/y_Alpha")
   (commit "Alpha")
+  
   (copy "b/x_Beta" "b/z_Beta")
   (commit "Beta")
 
+  (create "z/x_Zeta")
+  (create "z/y_Zeta")
+  (commit "Zeta")
+  
   (fork
    (lambda ()
      (create "c/x_Gamma")
      (commit "Gamma")
+     
      (modify "a/z_Alpha")
-     (commit "Alpha"))
+     (commit "Alpha")
+     
+     (create "e/x_Epsilon")
+     (commit "Epsilon")
+     
+     (move "z/x_Zeta" "zeta/x_Zeta")
+     (commit "Zeta"))
    (lambda ()
      (create "d/x_Delta")
      (commit "Delta")
+     
      (modify "b/z_Beta")
      (move "b/y_Beta" "c/y_Beta")
-     (commit "Beta")))
+     (commit "Beta")
+     
+     (create "e/y_Epsilon")
+     (commit "Epsilon")
+     
+     (move "z/y_Zeta" "zeta/y_Zeta")
+     (commit "Zeta")))
 
   ;; Move all into place:
   (move "a/z_Alpha" "alpha/x_Alpha")
@@ -125,12 +154,15 @@
   (move "b/z_Beta" "beta/z_Beta")
   (move "c/x_Gamma" "gamma/x_Gamma")
   (move "d/x_Delta" "delta/x_Delta")
-  (commit "Alpha" "Beta" "Gamma" "Delta"))
+  (move "e/x_Epsilon" "epsilon/x_Epsilon")
+  (move "e/y_Epsilon" "epsilon/y_Epsilon")
+  (commit "Alpha" "Beta" "Gamma" "Delta" "Epsilon"))
 
 ;; ----------------------------------------
 ;; Extract and check slices
 
-(define (slice slice)
+(define (slice slice [extra-commit? #f])
+  (printf "~a\nSLICING ~a...\n" (make-string 60 #\=) slice)
   (define slice-dir (build-path work-dir "slice"))
   (reset-dir slice-dir)
   (parameterize ([current-directory work-dir])
@@ -160,15 +192,22 @@
          [(regexp-match? #rx"^CHANGED: " l)
           (check-true (member slice (string-split l)))]
          [else count])))
-    (check-equal? commit-count (hash-ref commit-counts slice))
-    (unless (equal? commit-count (hash-ref commit-counts slice))
+    (define expected-count  (+ (hash-ref commit-counts slice)
+                               (if extra-commit? 1 0)))
+    (check-equal? commit-count expected-count)
+    (unless (equal? commit-count expected-count)
       (exit))
-    ))
+    
+    ;; Checks that we didn't create a repo with multiple
+    ;; initial commits (which is a danger with Epsilon):
+    (call-with-values extract-commits void)))
 
 (slice "Alpha")
 (slice "Beta")
 (slice "Gamma")
 (slice "Delta")
+(slice "Epsilon" #t) ; extra commit is a new initial commit
+(slice "Zeta" #t) ; extra commit is a new head to join branches
 
 ;; ----------------------------------------