#!@GUILE@ \
--no-auto-compile -s
!#

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This script stages and commits changes to package definitions.

;;; Code:

(import (sxml xpath)
        (srfi srfi-1)
        (srfi srfi-2)
        (srfi srfi-9)
        (srfi srfi-11)
        (srfi srfi-26)
        (ice-9 format)
        (ice-9 popen)
        (ice-9 match)
        (ice-9 rdelim)
        (ice-9 textual-ports)
        (rnrs control))

(define (read-excursion port)
  "Read an expression from PORT and reset the port position before returning
the expression."
  (let ((start (ftell port))
        (result (read port)))
    (seek port start SEEK_SET)
    result))

(define (surrounding-sexp port line-no)
  "Return the top-level S-expression surrounding the change at line number
LINE-NO in PORT."
  (let loop ((i (1- line-no))
             (last-top-level-sexp #f))
    (if (zero? i)
        last-top-level-sexp
        (match (peek-char port)
          (#\(
           (let ((sexp (read-excursion port)))
             (read-line port)
             (loop (1- i) sexp)))
          (_
           (read-line port)
           (loop (1- i) last-top-level-sexp))))))

(define-record-type <hunk>
  (make-hunk file-name
             old-line-number
             new-line-number
             diff-lines
             definition?)
  hunk?
  (file-name       hunk-file-name)
  ;; Line number before the change
  (old-line-number hunk-old-line-number)
  ;; Line number after the change
  (new-line-number hunk-new-line-number)
  ;; The full diff to be used with "git apply --cached"
  (diff-lines hunk-diff-lines)
  ;; Does this hunk add a definition?
  (definition? hunk-definition?))

(define* (hunk->patch hunk #:optional (port (current-output-port)))
  (let ((file-name (hunk-file-name hunk)))
    (format port
            "diff --git a/~a b/~a~%--- a/~a~%+++ b/~a~%~a"
            file-name file-name file-name file-name
            (string-join (hunk-diff-lines hunk) ""))))

(define (diff-info)
  "Read the diff and return a list of <hunk> values."
  (let ((port (open-pipe* OPEN_READ
                          "git" "diff"
                          "--no-color"
                          "--no-prefix"
                          ;; Only include one context line to avoid lumping in
                          ;; new definitions with changes to existing
                          ;; definitions.
                          "--unified=1"
                          "gnu")))
    (define (extract-line-number line-tag)
      (abs (string->number
            (car (string-split line-tag #\,)))))
    (define (read-hunk)
      (let loop ((lines '())
                 (definition? #false))
        (let ((line (read-line port 'concat)))
          (cond
           ((eof-object? line)
            (values (reverse lines) definition?))
           ((or (string-prefix? "@@ " line)
                (string-prefix? "diff --git" line))
            (unget-string port line)
            (values (reverse lines) definition?))
           (else
            (loop (cons line lines)
                  (or definition?
                      (string-prefix? "+(define" line))))))))
    (define info
      (let loop ((acc '())
                 (file-name #f))
        (let ((line (read-line port)))
          (cond
           ((eof-object? line) acc)
           ((string-prefix? "--- " line)
            (match (string-split line #\space)
              ((_ file-name)
               (loop acc file-name))))
           ((string-prefix? "@@ " line)
            (match (string-split line #\space)
              ((_ old-start new-start . _)
               (let-values
                   (((diff-lines definition?) (read-hunk)))
                 (loop (cons (make-hunk file-name
                                        (extract-line-number old-start)
                                        (extract-line-number new-start)
                                        (cons (string-append line "\n")
                                              diff-lines)
                                        definition?) acc)
                       file-name)))))
           (else (loop acc file-name))))))
    (close-pipe port)
    info))

(define (lines-to-first-change hunk)
  "Return the number of diff lines until the first change."
  (1- (count (lambda (line)
               ((negate char-set-contains?)
                (char-set #\+ #\-)
                (string-ref line 0)))
             (hunk-diff-lines hunk))))

(define (old-sexp hunk)
  "Using the diff information in HUNK return the unmodified S-expression
corresponding to the top-level definition containing the staged changes."
  ;; TODO: We can't seek with a pipe port...
  (let* ((port (open-pipe* OPEN_READ
                           "git" "show" (string-append "HEAD:"
                                                       (hunk-file-name hunk))))
         (contents (get-string-all port)))
    (close-pipe port)
    (call-with-input-string contents
      (lambda (port)
        (surrounding-sexp port
                          (+ (lines-to-first-change hunk)
                             (hunk-old-line-number hunk)))))))

(define (new-sexp hunk)
  "Using the diff information in HUNK return the modified S-expression
corresponding to the top-level definition containing the staged changes."
  (call-with-input-file (hunk-file-name hunk)
    (lambda (port)
      (surrounding-sexp port
                        (+ (lines-to-first-change hunk)
                           (hunk-new-line-number hunk))))))

(define (keyword-list->alist kwlist)
  (match kwlist
    (() '())
    (((? keyword? k) object . rest)
     `((,k . ,object) . ,(keyword-list->alist rest)))))

(define (pairwise-foreach-keyword proc . arguments)
  "Apply PROC with each keyword argument and corresponding values
in ARGUMENTS.  If a value is not present in a argument, pass #f instead."
  (let* ((alists (map keyword-list->alist arguments))
         (keywords (delete-duplicates
                    (apply append (map (cut map car <>) alists))
                    eq?)))
    (for-each (lambda (keyword)
                (apply proc keyword
                       (map (cut assoc-ref <> keyword) alists)))
              keywords)))

(define* (explain-list-delta old new #:key pairwise/change)
  "Try to explain the changes from the list OLD to NEW.

If passed, the explainer @var{pairwise/change} must accept two
arguments: an entry of @var{old} and @var{new}. It can be called
for each pair of old and new entries.  It should return truth if
the change could be explained, and false otherwise.

Return false if all changes could be explained and truth otherwise."
  (let* ((old-vector (list->vector old))
         (new-vector (list->vector new))
         (old-explained? (make-bitvector (vector-length old-vector) #f))
         (new-explained? (make-bitvector (vector-length new-vector) #f)))
    (do ((i 0 (and (< (+ i 1) (vector-length old-vector))
                   (bitvector-position old-explained? #f (+ 1 i)))))
        ((not i))
      (do ((j 0 (and (< (+ j 1) (vector-length new-vector))
                     (bitvector-position new-explained? #f (+ 1 j)))))
          ((not j))
        (cond ((or (bitvector-bit-set? old-explained? i)
                   (bitvector-bit-set? new-explained? j)))
              ;; If two entries are equal, there is no change.
              ;; (Except possibly some reordering, which we currently
              ;; do not check for.)
              ((equal? (vector-ref old-vector i)
                       (vector-ref new-vector j))
               (bitvector-set-bit! old-explained? i)
               (bitvector-set-bit! new-explained? j))
              ((and pairwise/change
                    (pairwise/change (vector-ref old-vector i)
                                     (vector-ref new-vector j)))
               (bitvector-set-bit! old-explained? i)
               (bitvector-set-bit! new-explained? j)))))
    (or (bitvector-position old-explained? #f)
        (bitvector-position new-explained? #f))))

(define (has-explicit-argument? argument-to-search-for argument-list)
  "Test whether ARGUMENT-TO-SEARCH-FOR occurs in ARGUMENT-LIST."
  (let loop ((argument-list argument-list))
    ;; (lambda () exp)
    (cond ((null? argument-list) #f)
          ;; (lambda (x . rest) exp)
          ((pair? argument-list)
           (let ((argument-in-list (car argument-list))
                 (rest (cdr argument-list)))
             (cond ((eq? argument-in-list argument-to-search-for)
                    #t)
                   ;; (lambda* (#:key (x . default) . rest) #f)
                   ((and (pair? argument-in-list)
                         (eq? (car argument-in-list) argument-to-search-for))
                    #t)
                   (#t (loop rest)))))
          ;; (lambda _ exp)
          ((symbol? argument-list) #f)
          (#t (error "the argument list seems to be incorrect!")))))

(define* (change-commit-message file-name old new #:optional (port (current-output-port)))
  "Print ChangeLog commit message for changes between OLD and NEW."
  (define (get-values expr field)
    (match ((sxpath `(// ,field quasiquote *)) expr)
      (() '())
      ((first . rest)
       (map cadadr first))))
  ;; Like get-values, but also allow quote and do not treat
  ;; the value of the field as an alist.
  (define (get-values/list expr field)
    (match ((sxpath `(// ,field ,(node-or (sxpath '(quasiquote))
                                          (sxpath '(quote))))) expr)
      (() '())
      ((first . rest)
       (second first))))
  (define (listify items)
    (match items
      ((one) one)
      ((one two)
       (string-append one " and " two))
      ((one two . more)
       (string-append (string-join (drop-right items 1) ", ")
                      ", and " (first (take-right items 1))))))
  (define variable-name
    (second old))
  (define version
    (and=> ((sxpath '(// version *any*)) new)
           first))
  (format port
          "gnu: ~a: Update to ~a.~%~%* ~a (~a): Update to ~a.~%"
          variable-name version file-name variable-name version)
  (for-each (lambda (field)
              (let ((old-values (get-values old field))
                    (new-values (get-values new field)))
                (or (equal? old-values new-values)
                    (let ((removed (lset-difference equal? old-values new-values))
                          (added (lset-difference equal? new-values old-values)))
                      (format port
                              "[~a]: ~a~%" field
                              (match (list (map symbol->string removed)
                                           (map symbol->string added))
                                ((() added)
                                 (format #f "Add ~a."
                                         (listify added)))
                                ((removed ())
                                 (format #f "Remove ~a."
                                         (listify removed)))
                                ((removed added)
                                 (format #f "Remove ~a; add ~a."
                                         (listify removed)
                                         (listify added)))))))))
            '(inputs propagated-inputs native-inputs))
  (define (explain-make-flags/change x y)
    (match (cons x y)
      (("CC=gcc" . ',(string-append "CC=" (cc-for-target)))
       (format port
               " Use the C cross-compiler, instead of hardcoding \"gcc\".")
       #t)
      (("CXX=g++" . ',(string-append "CXX=" (cxx-for-target)))
       (format port
               " Use the C++ cross-compiler, instead of hardcoding \"g++\".")
       #t)
      (_ #f)))
  (define (explain-phases/change x y)
    (match (cons x y)
      ;; "guix build" supports a --without-tests=PACKAGE option,
      ;; for building a package without running tests.  Also, tests
      ;; can often not be run when cross-compiling.  The 'check'
      ;; phase needs to respect this, though.  Maybe this patch is
      ;; for ensuring the phase respects this.
      ((('replace ''check ((or 'lambda* 'lambda) args/x . exps/x))
        . ('replace ''check ((or 'lambda* 'lambda) args/y . exps/y)))
       (when (and (not (has-explicit-argument? 'tests? args/x))
                  (has-explicit-argument? 'tests? args/y))
         (format port
                 "[arguments]<#:phases>{check}: Only run tests when not requested.~%")
         #t))
      (_ #f)))
  (define (explain-argument keyword old new)
    (unless (equal? old new)
      (case keyword
        ((#:make-flags)
         (format port "[arguments]<#:make-flags>:")
         ;; second: skip ' and `
         (if (explain-list-delta (second old) (second new)
                                 #:pairwise/change explain-make-flags/change)
             ;; There were some unexplained changes.
             (format port " Update.~%")
             (format port "~%")))
        ((#:phases)
         ;; For each phase, a separate line will be printed.
         (match (cons old new)
           ;; _ can be %standard-phases, for example
           ((('modify-phases _ . rest/old) . ('modify-phases _ . rest/new))
            (if (explain-list-delta rest/old rest/new
                                    #:pairwise/change explain-phases/change)
                ;; There were some unexplained changes.
                (format port "[arguments]<#:phases>: Update.~%")))
           ;; There were some unexplained changes.
           (_ (format port "[arguments]<#:phases>: Update.~%"))))
        ;; There were some unexplained changes.
        (else (format port "[arguments]<~a>: Update.~%" keyword)))))
  (let ((old-arguments (or (get-values/list old 'arguments) '()))
        (new-arguments (or (get-values/list new 'arguments) '())))
    (pairwise-foreach-keyword explain-argument old-arguments
                              new-arguments)))

(define* (add-commit-message file-name variable-name #:optional (port (current-output-port)))
  "Print ChangeLog commit message for a change to FILE-NAME adding a definition."
  (format port
          "gnu: Add ~a.~%~%* ~a (~a): New variable.~%"
          variable-name file-name variable-name))

(define (group-hunks-by-sexp hunks)
  "Return a list of pairs associating all hunks with the S-expression they are
modifying."
  (fold (lambda (sexp hunk acc)
          (match acc
            (((previous-sexp . hunks) . rest)
             (if (equal? sexp previous-sexp)
                 (cons (cons previous-sexp
                             (cons hunk hunks))
                       rest)
                 (cons (cons sexp (list hunk))
                       acc)))
            (_
             (cons (cons sexp (list hunk))
                   acc))))
        '()
        (map new-sexp hunks)
        hunks))

(define (new+old+hunks hunks)
  (map (match-lambda
         ((new . hunks)
          (cons* new (old-sexp (first hunks)) hunks)))
       (group-hunks-by-sexp hunks)))

(define %delay 1000)

(define (main . args)
  (match (diff-info)
    (()
     (display "Nothing to be done." (current-error-port)))
    (hunks
     (let-values
         (((definitions changes)
           (partition hunk-definition? hunks)))

       ;; Additions.
       (for-each (lambda (hunk)
                   (and-let*
                       ((define-line (find (cut string-prefix? "+(define" <>)
                                           (hunk-diff-lines hunk)))
                        (variable-name (and=> (string-tokenize define-line) second)))
                     (add-commit-message (hunk-file-name hunk) variable-name)
                     (let ((port (open-pipe* OPEN_WRITE                   
                                             "git" "apply"                
                                             "--cached"                   
                                             "--unidiff-zero")))          
                       (hunk->patch hunk port)                            
                       (unless (eqv? 0 (status:exit-val (close-pipe port))) 
                         (error "Cannot apply")))

                     (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
                       (add-commit-message (hunk-file-name hunk)
                                           variable-name port)
                       (usleep %delay)
                       (unless (eqv? 0 (status:exit-val (close-pipe port)))
                         (error "Cannot commit"))))
                   (usleep %delay))
                 definitions)

       ;; Changes.
       (for-each (match-lambda
                   ((new old . hunks)
                    (for-each (lambda (hunk)
                                (let ((port (open-pipe* OPEN_WRITE
                                                        "git" "apply"
                                                        "--cached"
                                                        "--unidiff-zero")))
                                  (hunk->patch hunk port)
                                  (unless (eqv? 0 (status:exit-val (close-pipe port)))
                                    (error "Cannot apply")))
                                (usleep %delay))
                              hunks)
                    (change-commit-message (hunk-file-name (first hunks))
                                           old new
                                           (current-output-port))
                    (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
                      (change-commit-message (hunk-file-name (first hunks))
                                             old new
                                             port)
                      (usleep %delay)
                      (unless (eqv? 0 (status:exit-val (close-pipe port)))
                        (error "Cannot commit")))))
                 ;; XXX: we recompute the hunks here because previous
                 ;; insertions lead to offsets.
                 (new+old+hunks (diff-info)))))))

(main)