(use-modules
 (gnu installer utils)
 (graph topological-sort)
 (guix build utils)
 (ice-9 exceptions)
 (ice-9 hash-table)
 (ice-9 match)
 (ice-9 popen)
 (ice-9 rdelim)
 (oop goops)
 (srfi srfi-1)
 (srfi srfi-13)
 (srfi srfi-2)
 (srfi srfi-26)
 (gnu packages)
 (guix packages))

(with-exception-handler
    exception-irritants
  (lambda ()
    (package-propagated-inputs
     (module-ref
      (reload-module (resolve-module '(gnu packages ocaml-mirage) #:ensure #f))
      'ocaml-ppx-cstruct)))
  #:unwind? #t
  #:unwind-for-type &undefined-variable)

(define from-commit "raingloom/mirageos-rebase")
(define to-commit "after-dune")

;; The set (sorted list) of variables (symbols) we care about.
(define variables-of-interest
  ;; starts out as #f to catch errors
  (make-parameter #f))

(define variable->commit-mapping
 (make-parameter #f))

(define dependency-digraph
  (make-parameter #f))

(define commit->log-index
  (make-parameter #f))

(define (with-input-from-make thunk)
  (lambda _
    (with-input-from-port
        (open-pipe* OPEN_READ "make")
      thunk)))

(define (set-current-commit! commit)
  (invoke "git" "checkout" commit))

(define (missing-variable-on-line line)
  (and-let*
      ((words (string-split line #\space))
       (prefixed-var (find-tail (cut string=? "variable" <>) words))
       ;; so cadr doesn't error
       (prefixed-var-ok? (equal? 2 (length prefixed-var)))
       (var-quoted (cadr prefixed-var))
       (var-quoted-ok? (and (string-suffix? "'" var-quoted)
                            (string-prefix? "`" var-quoted)))
       (var (string-drop-right (string-drop var-quoted 1) 1)))
    var))

(define (with-input-from-command thunk command)
  ;; TODO this is ugly, but run-external-command-with-handler does not return
  ;; the value that the handler returns, only the command's exit status
  (define ret #f)
  (define (handler port)
    (set! ret (with-input-from-port port thunk)))
  (run-external-command-with-handler handler command)
  ret)

(define (current-commit-missing-definitions)
  (define (go)
    (let ((line (read-line)))
      (if (eof-object? line)
          '()
          (let ((variable (missing-variable-on-line line)))
            (if variable
                (cons variable (go))
                (go))))))
  (map string->symbol
       (with-input-from-command go '("make"))))

(define (name->commit name)
   (define (go)
     (define hash (read-line))
     (unless (eof-object? (read-line))
       (error "unexpected additional output"))
     hash)
   (with-input-from-command
    go
    `("git" "show" "--format=%H" "--quiet" ,name)))

(define (current-commit)
  (name->commit "HEAD"))

(define (commits-since commit-name)
  (define commit (name->commit commit-name))
  (define (go)
    (let ((line (read-line)))
      (cond
       ((eof-object? line) (error "ancestor commit does not exist"))
       ((string=? line commit) '())
       (else (cons line (go))))))
  (reverse (with-input-from-command go '("git" "log" "--format=%H"))))

(define (files-changed commit)
  (cdr (with-input-from-command
        read-lines
        `("git" "show" "--oneline" "--name-only" ,commit))))

(define (module-file? file)
  (string-suffix? ".scm" file))

(define (path->module path)
  "Assumes PATH is a valid Scheme file."
  (let* ((components-rev (reverse (string-split path #\/)))
         (base (car components-rev))
         (last-component (string-drop-right base (string-length ".scm"))))
    (map string->symbol (reverse (cons last-component (cdr components-rev))))))

(define (modules-changed commit)
  (map path->module
       (filter module-file?
               (files-changed commit))))

(define (touch-changed-files! commit)
  (apply invoke (cons "touch" (files-changed commit))))

(define (commits+missing-definitions commits)
  (map (lambda (commit)
         (set-current-commit! commit)
         (touch-changed-files! commit)
         (cons commit (current-commit-missing-definitions)))
       commits))

(define (set-insert set x)
  "Insert element X into the sorted list SET."
  (match set
    (() (list x))
    ((a) (if (< a x)
             (list a x)
             (list x a)))
    ((a b . rest)
     (cond
      ((and (< a x) (< x b)) (cons* a x b rest))
      ((equal? a x) set)
      ((< x a) (cons* x a (cdr set)))
      (else (cons a (set-insert (cdr set) x)))))))

(define (add-dependent! dependency-graph commit dependent)
  (assoc-set! dependency-graph commit
              (set-insert dependent
                          (or (assoc-ref dependency-graph commit)
                              '()))))

(define (deduplicate lst)
  (define ret '())
  (for-each (lambda (x) (set! ret (assoc-set! ret x #t))) lst)
  (map car ret))

(define (current-commit-defined-vars-of-interest)
  (let ((vars-of-interest (variables-of-interest)))
    (deduplicate
     (concatenate
      (filter identity
              (map (lambda (module-name)
                     (let ((module (reload-module
                                    (resolve-module module-name))))
                       (map (lambda (var)
                              (and (module-variable
                                    module var) var))
                            vars-of-interest)))
                   (modules-changed (current-commit))))))))

;; : alist symbol (list string)
(define (compute-variable->commit-mapping! commits)
  (fold
   (lambda (commit vars->commits)
     (set-current-commit! commit)
     (fold
      (lambda (var vars->commits)
        (assoc-set! vars->commits var
                    (cons commit
                          (or (assoc-ref vars->commits var) '()))))
      vars->commits
      (current-commit-defined-vars-of-interest)))
   '()
   commits))

(define (order-in-topology  commit)
  (hash-ref (topology-vector) commit))

(define (order-in-log commit)
  (hash-ref (commit->log-index) commit))

(define (depends? commit dependency)
  "Does COMMIT depend on DEPENDENCY?"
  (sorted? (map order-in-topology (list commit dependency)) <))

(define (predates? a b)
  "Does commit A come before commit B in the original history?"
  (sorted? (map order-in-log (list a b)) <))

(define (commits-ordered? a b)
  "Commit A should come before B iff B has a direct dependency on A or if it
comes before B in the git history, in that order of precedence."
  (or (depends? a b)
      (predates? a b)))

(define (list->index-lookup-hash-table lst)
  (define mapping (make-hash-table))
  (fold (lambda (x i)
          (hash-set! mapping x i)
          (+ 1 i))
        0 lst)
  mapping)

(define (hash->alist hsh)
  (hash-fold acons '() hsh))

(set-current-commit! from-commit)
;; edges go from commits to variables
(define commits (commits-since to-commit))
(commit->log-index (list->index-lookup-hash-table commits))
(define commits->missing-definitions (commits+missing-definitions commits))
(variables-of-interest
 (deduplicate
  (apply append (map cdr commits->missing-definitions))))
(define var->comm
  (compute-variable->commit-mapping! commits))
(variable->commit-mapping (alist->hash-table var->comm))

(define graph-n (length commits))
(define graph (make-bitvector (expt graph-n 2)))
(define (coord->offset row col)
  (+ col (* graph-n row)))
(define (connected? a b)
  (bitvector-bit-set? graph (coord->offset a b)))
(define (connect! a b)
  (bitvector-set-bit! graph (coord->offset a b)))
(let ((variable->commit-mapping (variable->commit-mapping)))
  (for-each
   (match-lambda
     ((commit . vars)
      (let ((commit-log-id (order-in-log commit)))
        (for-each
         (lambda (var)
           (let* ((dependencies (hash-ref variable->commit-mapping var)))
             (for-each
              (lambda (dependency)
                (connect! commit-log-id (order-in-log dependency))))))
         vars))))
   commits->missing-definitions))