#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))