Re: committer.scm

[Csepp]

jgart <jgart@dismail.de> writes:

> On Tue, 01 Nov 2022 07:57:28 +0100 Julien Lepiller <julien@lepiller.eu> wrote:
>> Try calling it with pre-inst-env.
>
> Ohhh, yes that was it. I stopped calling it with pre-inst-env for some reason 
> ;()
>
> THNX
>
> Now I just need to see how I am going to sort these 150+ crates in an 
> automated fashion...

If you have some graph theory and Guix know-how you might be able to get
my commit sorter script working.  Currently it's broken, as in it does
not sort commits in the way they should be sorted, but it has a lot of
useful bits already.

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