compute.rkt

#lang racket

(require "git.rkt")
(provide go)

(define (go subdir dest-dir tmp-dir dry-run?)
  (printf "# git-slice: computing commits ...\n\n")
  (define start-time (current-milliseconds))
  
  (printf "Using temporary directory ~a\n" (path->string dest-dir))
  (when tmp-dir
    (printf "Using scratch directory ~a\n" (path->string tmp-dir)))
  
  (define exists-flag (if dry-run? 'error 'truncate))
  
  (define-values (commits head-commit commit->parents commit->children)
    (extract-commits))
  
  ;; One particular path that we sync forks to:
  (define main-line-commits
    (let loop ([a head-commit])
      (cons a
            (let ([p (hash-ref commit->parents a)])
              (if (null? p)
                  null
                  (loop (car p)))))))
  
  (define commit->main?
    (for/hash ([f (in-list main-line-commits)])
      (values f #t)))
  
  ;; To find a commit that is on all paths from head to the initial
  ;; commit:
  (define (find-newest-older-cut p)
    (define (can-reach-root-without? without)
      (define seen (make-hash))
      (let loop ([p head-commit])
        (cond
         [(hash-ref seen p #f)
          #f]
         [else
          (hash-set! seen p #t)
          (define ps (hash-ref commit->parents p))
          (or (null? ps)
              (for/or ([p (in-list ps)])
                (and (not (equal? p without))
                     (loop p))))])))
    (let loop ([p p])
      (if (can-reach-root-without? p)
          ;; Try ancestor, skipping ahead to an ancestor that at least
          ;; has two children:
          (let c-loop ([p (car (hash-ref commit->parents p))])
            (if (= 1 (length (hash-ref commit->children p)))
                (c-loop (car (hash-ref commit->parents p)))
                (loop p)))
          p)))

  (define (advance-to-main/newer commit)
    (if (hash-ref commit->main? commit #f)
        commit
        (advance-to-main/newer (car (hash-ref commit->children commit)))))

  (define (advance-to-main/older commit)
    (if (hash-ref commit->main? commit #f)
        commit
        (advance-to-main/older (car (hash-ref commit->parents commit)))))

  (define files
    (for/list ([f (in-directory subdir)]
               #:when (file-exists? f))
      (path->bytes f)))
  
  (define lifetimes (make-hash))
  (define relevants (make-hash))
  
  ;; Since a file can be copied, it might have multiple "ending"
  ;; points in the lifetimes of different files, so make sure we
  ;; consider its latest ending point.
  (define (already-started-later? f start-commit)
    (define lt (hash-ref lifetimes f #f))
    (and lt
         (let ([old-start-commit (car lt)])
           (define m (member old-start-commit main-line-commits))
           (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 'git-slice "new start commit not found in main line: ~a" start-commit))
                 #f)))))
  
  ;; Determine the commit range that applies to a file.
  ;; We use `git log --follow' for this, because it's good
  ;; at find the point at which a file name changes.
  ;; We don't use `git log --follow' to get the full history
  ;; of a file, because it's incomplete after a rename.
  (define (find-lifetime! f start-commit)
    (unless (already-started-later? f start-commit)
      (let ([current-name f]
            [prev-name #f]
            [in-commit #f]
            [done? #f])
        (define (do-commit!)
          (when (and in-commit prev-name)
            (printf "~a : ~a...~a^\n" prev-name start-commit in-commit)
            (hash-set! lifetimes prev-name (cons start-commit in-commit))
            (find-lifetime! current-name (advance-to-main/newer in-commit))
            (set! done? #t)))
        (void
         (filter-input
          (lambda (l)
            (cond
              [done? (void)]
              [(regexp-match #rx"^commit (.*)$" l)
               =>
               (lambda (m)
                 (do-commit!)
                 (set! in-commit (cadr m))
                 (hash-set! relevants in-commit #t))]
              [(regexp-match #rx#"^(?:copy|rename) to (.*)$" l)
               =>
               (lambda (m)
                 (define old-name (cadr m))
                 (unless (equal? old-name prev-name)
                   (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
                          f)))]
              [(regexp-match #rx#"^(?:copy|rename) from (.*)$" l)
               =>
               (lambda (m)
                 (set! prev-name current-name)
                 (set! current-name (cadr m)))])
            #f)
          git-exe
          "log"
          "--follow"
          "-p"
          start-commit
          "--"
          f))
        (unless done?
          (do-commit!))
        (unless done?
          (printf "~a : ~a...\n" current-name start-commit)
          (hash-set! lifetimes current-name (cons start-commit #f))))))
  
  ;; Collect lifetimes of all interesting files, starting
  ;; with the ones we want in the end:
  (for ([f (in-list (sort files bytes<?))])
    (find-lifetime! f head-commit))
  
  (define commit->actions (make-hash))
  
  (for ([(f lt) (in-hash lifetimes)])
    (hash-update! commit->actions
                  (car lt)
                  (lambda (l)
                    (cons `(leave ,f) l))
                  null)
    (hash-update! commit->actions
                  (cdr lt)
                  (lambda (l)
                    (cons `(enter ,f) l))
                  null))
  
  (with-output-to-file (build-path dest-dir "state.rktd")
    #:exists exists-flag
    (lambda ()
      (write
       (for/hash ([a (in-list (hash-ref commit->actions #f null))])
         (values (cadr a) #t)))))
  
  (hash-remove! commit->actions #f)
  (with-output-to-file (build-path dest-dir "actions.rktd")
    #:exists exists-flag
    (lambda ()
      (write (for/hash ([(k v) (in-hash commit->actions)])
               (values (string->bytes/utf-8 k) v)))))
  
  (define oldest-relevant-commit
    (let ([advanced-relevants
           (for/hash ([c (in-hash-keys relevants)])
             (values (advance-to-main/older c) #t))])
      (let loop ([cs main-line-commits] [c head-commit])
        (cond
          [(null? cs) c]
          [(hash-ref advanced-relevants (car cs) #f)
           (loop (cdr cs) (car cs))]
          [else (loop (cdr cs) c)]))))
  (printf "Looking for cut older than ~a...\n" oldest-relevant-commit)
  (define oldest-relevant
    (find-newest-older-cut oldest-relevant-commit))

  (printf "relevant commits bounded by ~a\n" oldest-relevant)
  (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 ()
      (write (for/hash ([(k v) (in-hash relevants)])
               (values (string->bytes/utf-8 k) v)))))
  
  (with-output-to-file (build-path dest-dir "oldest.rktd")
    #:exists exists-flag
    (lambda ()
      (write (list oldest-relevant
                   (let ([parents (hash-ref commit->parents oldest-relevant)])
                     (and (pair? parents) (car parents)))
                   drop-oldest?))))
  
  (define how-many-relevant? (hash-count relevants))
  (define how-many-filtered? (for/sum ([i (in-list commits)]
                                       #:break (equal? i oldest-relevant))
                               1))
  
  (define end-time (current-milliseconds))
  (printf "\n### git-slice: computed commits in ~a seconds\n" (/ (- end-time start-time) 1000.))
  (values end-time how-many-relevant? how-many-filtered?))

(module+ main
  (define tmp-dir #f)
  (define dry-run? #f)
  (define-values (subdir dest-dir)
    (command-line
     #:once-each
     ["-d" scratch-dir
           "use <scratch-dir> as temporary working directory for `git filter-branch'"
           (set! tmp-dir (path->complete-path scratch-dir))]
     ["--dry-run"
      "describe but don't do destructive operations"
      (set! dry-run? #t)]
     #:args
     (subdir dest-dir)
     (values subdir (path->complete-path dest-dir))))
  (go subdir dest-dir tmp-dir dry-run?)
  (void))