03/06: maint: Add 'update-guix-package' target.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 94fa8d76163bd08e6f680dc300b551f36415687e
Author: Ludovic Courtès <address@hidden>
Date:   Sat May 6 22:59:05 2017 +0200

    maint: Add 'update-guix-package' target.
    
    * build-aux/update-guix-package.scm: New file.
    * Makefile.am (EXTRA_DIST): Add it.
    (update-guix-package): New target.
    (.PHONY): Add it.
    * gnu/packages/package-management.scm (guix): Mention it.
---
 Makefile.am                         |   8 +++
 build-aux/update-guix-package.scm   | 135 ++++++++++++++++++++++++++++++++++++
 gnu/packages/package-management.scm |   2 +
 3 files changed, 145 insertions(+)

diff --git a/Makefile.am b/Makefile.am
index 8fe9e35..ee8fa1f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -416,6 +416,7 @@ EXTRA_DIST =                                                
\
   build-aux/download.scm                               \
   build-aux/generate-authors.scm                       \
   build-aux/test-driver.scm                            \
+  build-aux/update-guix-package.scm                    \
   build-aux/run-system-tests.scm                       \
   d3.v3.js                                             \
   graph.js                                             \
@@ -539,6 +540,12 @@ gen-AUTHORS:
            "$(top_srcdir)" "$(distdir)/AUTHORS";               \
        fi
 
+update-guix-package:
+       git rev-parse HEAD
+       $(top_builddir)/pre-inst-env "$(GUILE)"                 \
+          $(top_srcdir)/build-aux/update-guix-package.scm      \
+          "`git rev-parse HEAD`"
+
 # Make sure we're not shipping a file that embeds a local /gnu/store file name.
 assert-no-store-file-names:
        $(AM_V_at)if grep -r --exclude=*.texi --exclude=*.info                  
\
@@ -574,6 +581,7 @@ hydra-jobs.scm: $(GOBJECTS)
 .PHONY: assert-no-store-file-names assert-binaries-available
 .PHONY: assert-final-inputs-self-contained
 .PHONY: clean-go make-go
+.PHONY: update-guix-package
 
 ## -------------- ##
 ## Silent rules.  ##
diff --git a/build-aux/update-guix-package.scm 
b/build-aux/update-guix-package.scm
new file mode 100644
index 0000000..d45c183
--- /dev/null
+++ b/build-aux/update-guix-package.scm
@@ -0,0 +1,135 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ludovic Courtès <address@hidden>
+;;;
+;;; 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 scripts updates the definition of the 'guix' package in Guix for the
+;;; current commit.  It requires Git to be installed.
+;;;
+;;; Code:
+
+(use-modules (guix)
+             (guix git-download)
+             (guix upstream)
+             (guix utils)
+             (guix base32)
+             (guix build utils)
+             (gnu packages package-management)
+             (ice-9 match))
+
+(define %top-srcdir
+  (string-append (current-source-directory) "/.."))
+
+(define version-controlled?
+  (git-predicate %top-srcdir))
+
+(define (package-definition-location)
+  "Return the source properties of the definition of the 'guix' package."
+  (call-with-input-file (location-file (package-location guix))
+    (lambda (port)
+      (let loop ()
+        (match (read port)
+          ((? eof-object?)
+           (error "definition of 'guix' package could not be found"
+                  (port-filename port)))
+          (('define-public 'guix value)
+           (source-properties value))
+          (_
+           (loop)))))))
+
+(define* (update-definition commit hash
+                            #:key version old-hash)
+  "Return a one-argument procedure that takes a string, the definition of the
+'guix' package, and returns a string, the update definition for VERSION,
+COMMIT."
+  (define (linear-offset str line column)
+    ;; Return the offset in characters to reach LINE and COLUMN (both
+    ;; zero-indexed) in STR.
+    (call-with-input-string str
+      (lambda (port)
+        (let loop ((offset 0))
+          (cond ((and (= (port-column port) column)
+                      (= (port-line port) line))
+                 offset)
+                ((eof-object? (read-char port))
+                 (error "line and column not reached!"
+                        str))
+                (else
+                 (loop (+ 1 offset))))))))
+
+  (define (update-hash str)
+    ;; Replace OLD-HASH with HASH in STR.
+    (string-replace-substring str
+                              (bytevector->nix-base32-string old-hash)
+                              (bytevector->nix-base32-string hash)))
+
+  (lambda (str)
+    (match (call-with-input-string str read)
+      (('let (('version old-version)
+              ('commit old-commit)
+              ('revision old-revision))
+         defn)
+       (let* ((location (source-properties defn))
+              (line     (assq-ref location 'line))
+              (column   0)
+              (offset   (linear-offset str line column)))
+         (string-append (format #f "(let ((version \"~a\")
+        (commit \"~a\")
+        (revision ~a))\n"
+                                (or version old-version)
+                                commit
+                                (if (and version
+                                         (not (string=? version old-version)))
+                                    0
+                                    (+ 1 old-revision)))
+                        (string-drop (update-hash str) offset))))
+      (exp
+       (error "'guix' package definition is not as expected" exp)))))
+
+
+(define (main . args)
+  (match args
+    ((commit version)
+     (with-store store
+       (let* ((source   (add-to-store store
+                                      "guix-checkout" ;dummy name
+                                      #t "sha256" %top-srcdir
+                                      #:select? version-controlled?))
+              (hash     (query-path-hash store source))
+              (location (package-definition-location))
+              (old-hash (origin-sha256 (package-source guix))))
+         (edit-expression location
+                          (update-definition commit hash
+                                             #:old-hash old-hash
+                                             #:version version))
+
+         ;; Re-add SOURCE to the store, but this time under the real name used
+         ;; in the 'origin'.  This allows us to build the package without
+         ;; having to make a real checkout; thus, it also works when working
+         ;; on a private branch.
+         (reload-module
+          (resolve-module '(gnu packages package-management)))
+         (pk source
+             (add-to-store store
+                           (origin-file-name (package-source guix))
+                           #t "sha256" source)))))
+    ((commit)
+     ;; Automatically deduce the version and revision numbers.
+     (main commit #f))))
+
+(apply main (cdr (command-line)))
diff --git a/gnu/packages/package-management.scm 
b/gnu/packages/package-management.scm
index 0c69cda..467613e 100644
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@@ -70,6 +70,8 @@
 
 (define-public guix
   ;; Latest version of Guix, which may or may not correspond to a release.
+  ;; Note: the 'update-guix-package.scm' script expects this definition to
+  ;; start precisely like this.
   (let ((version "0.12.0")
         (commit "25a49294caf2386e65fc1b12a2508324be0b1cc2")
         (revision 9))