Guix: cean up the bootstrap source.

2 files changed, 114 insertions, 31 deletions

diff --git a/cfg.mk b/cfg.mk
index 8611d1a..f309a76 100644
--- a/cfg.mk
+++ b/cfg.mk
@@ -16,8 +16,10 @@ push-updated-translations:
 	(cd translations-updated && git add *.po && git commit -m"Update translations" && git push)
 	@rm -rf translations-updated
 
+list_authors = $(GIT) log --pretty=format:%an
+
 sc_git_authors_known:
-	@$(GIT) log --pretty=format:%an \
+	@$(list_authors) \
 	  | sort -u \
 	  | while read line ; \
 	    do $(GREP) "$$line" $(srcdir)/AUTHORS >/dev/null 2>&1 \
diff --git a/guix.scm b/guix.scm
index 203afe1..475946b 100644
--- a/guix.scm
+++ b/guix.scm
@@ -6,6 +6,7 @@
   #:use-module (gnu packages check)
   #:use-module (gnu packages code)
   #:use-module (gnu packages compression)
+  #:use-module (gnu packages cppi)
   #:use-module (gnu packages gettext)
   #:use-module (gnu packages glib)
   #:use-module (gnu packages gnome)
@@ -30,6 +31,7 @@
   #:use-module (guix monads)
   #:use-module (guix derivations)
   #:use-module (guix download)
+  #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
   #:use-module (ice-9 rdelim)
   #:use-module (srfi srfi-19))
@@ -72,13 +74,88 @@
         (close-port port)
         (string->date date "~Y-~m-~d ~H:~M:~S ~z")))))
 
-(define disfluid:manual-update-date
+(define disfluid:source-file-db
+  (let ((all-source-files
+         (let ((port (open-pipe* OPEN_READ git-exec "ls-tree" "-r" "--name-only" "HEAD")))
+           (let take-all ((taken '()))
+             (let ((next (read-line port)))
+               (cond
+                ((eof-object? next)
+                 (begin
+                   (close-port port)
+                   (reverse taken)))
+                ((string=? next "gnulib")
+                 ;; Ignore submodules
+                 (take-all taken))
+                (else
+                 (take-all `(,next ,@taken)))))))))
+    (map
+     (lambda (source-file)
+       `(,source-file
+         ,(let ((port (open-pipe* OPEN_READ git-exec "log" "--pretty=format:%ai" "--author-date-order" source-file)))
+            (let ((date (read-line port)))
+              (when (eof-object? date)
+                (format (current-error-port) "Your git repository is not deep enough to find a modification date for ~s.\n"
+                        source-file)
+                (error "git repository too shallow"))
+              (close-port port)
+              (string->date date "~Y-~m-~d ~H:~M:~S ~z")))))
+     all-source-files)))
+
+(define disfluid:authors
   (with-directory-excursion
       (dirname (current-filename))
-    (let ((port (open-pipe* OPEN_READ git-exec "log" "-1" "--format=%ai" "doc/disfluid.texi")))
-      (let ((date (read-line port)))
-        (close-port port)
-        (string->date date "~Y-~m-~d ~H:~M:~S ~z")))))
+    (let ((port (open-pipe* OPEN_READ git-exec "log" "--pretty=format:%an")))
+      (let take-all ((taken '()))
+        (let ((next (read-line port)))
+          (if (eof-object? next)
+              (begin
+                (close-port port)
+                (reverse taken))
+              (take-all `(,next ,@taken))))))))
+
+(define vc-list
+  (program-file
+   "vc-list"
+   (with-imported-modules
+       (source-module-closure '((guix build utils)))
+     #~(begin
+         (use-modules (guix build utils))
+         (for-each
+          (lambda (source-file)
+            (format #t "~a\n" source-file))
+          '(#$@(map (match-lambda
+                      ((source-file _) source-file))
+                    disfluid:source-file-db)))))))
+
+(define find-mdate
+  (program-file
+   "find-mdate"
+   (with-imported-modules
+       (source-module-closure '((guix build utils)))
+     #~(begin
+         (use-modules (guix build utils))
+         (format #t "~a\n"
+                 #$(let find-manual ((db disfluid:source-file-db))
+                     (match db
+                       ((("doc/disfluid.texi" date) _ ...)
+                        (date->string date "~4"))
+                       ((_ db ...)
+                        (find-manual db))
+                       (()
+                        (error "doc/disfluid.texi is not in the source file db")))))))))
+
+(define list-authors
+  (program-file
+   "list-authors"
+   (with-imported-modules
+       (source-module-closure '((guix build utils)))
+     #~(begin
+         (use-modules (guix build utils))
+         (for-each
+          (lambda (author)
+            (format #t "~a\n" author))
+          '(#$@(begin disfluid:authors)))))))
 
 (define disfluid:local-dir
   (dirname (current-filename)))
@@ -92,6 +169,20 @@
    (url (string-append "file://" (dirname (current-filename))))
    (branch "translations")))
 
+(define po-download
+  (program-file
+   "po-download"
+   (with-imported-modules
+       (source-module-closure '((guix build utils)))
+     #~(begin
+         (use-modules (guix build utils) (ice-9 match))
+         (match (command-line)
+           ((_ directory _)
+            (mkdir-p directory)
+            (with-directory-excursion directory
+              (copy-recursively #$(file-append disfluid:translations "/.") "."
+                                #:follow-symlinks? #t))))))))
+
 (define disfluid:raw-source
   (computed-file "disfluid-raw-source"
     (with-imported-modules
@@ -100,30 +191,17 @@
           (use-modules (guix build utils))
           (mkdir-p #$output)
           (with-directory-excursion #$output
-            (invoke #$(file-append git "/bin/git") "init")
-            (invoke #$(file-append git "/bin/git") "branch" "-m" "main")
-            (invoke #$(file-append git "/bin/git") "config"
-                    "user.email" "vivien@planete-kraus.eu")
-            (invoke #$(file-append git "/bin/git") "config"
-                    "user.name" "Vivien Kraus")
             (copy-recursively #$(file-append disfluid:package-source "/.") "."
                               #:follow-symlinks? #t)
-            (invoke #$(file-append git "/bin/git") "add" ".")
-            (invoke #$(file-append git "/bin/git") "commit"
-                    "-m" #$(format #f "Set up disfluid source code for ~a" disfluid:package-version)
-                    #$(format #f "--date=~a" (date->string disfluid:manual-update-date "~4")))
-            (invoke #$(file-append git "/bin/git") "checkout" "-b" "translations")
-            (copy-recursively #$(file-append disfluid:translations "/.") "."
-                              #:follow-symlinks? #t)
-            (invoke #$(file-append git "/bin/git") "add" ".")
-            (false-if-exception
-             (invoke #$(file-append git "/bin/git") "commit"
-                     "-m" #$(format #f "Set up disfluid translations for ~a"
-                                    disfluid:package-version)))
-            (invoke #$(file-append git "/bin/git") "checkout" "main")
-            (invoke #$(file-append git "/bin/git") "tag" "-a"
-                    "-m" #$(format #f "Version ~a" disfluid:package-version)
-                    #$(format #f "v~a" disfluid:package-version)))))))
+            (call-with-output-file ".tarball-version"
+              (lambda (port)
+                (format port "~a\n" #$(begin disfluid:package-version))))
+            (substitute* "bootstrap.conf"
+              (("po_download_command_format=.*")
+               (format #f "po_download_command_format=~s"
+                       (string-append
+                        #$po-download
+                        " %s %s")))))))))
 
 (define-public disfluid-boot
   (package
@@ -147,10 +225,12 @@
 	         (format #f "SHELL = ~a" (which "sh"))))))
           (add-after 'check 'syntax-check
             (lambda _
-              (invoke "make" "syntax-check")))
+              (invoke "make" "syntax-check"
+                      (format #f "VC_LIST = ~a" #$vc-list)
+                      (format #f "list_authors = ~a" #$list-authors)
+                      (format #f "find_mdate = ~a" #$find-mdate))))
           (replace 'install
             (lambda _
-              (invoke "git" "checkout" "--" "bootstrap-bootstrap")
               (patch-shebang "configure")
               (invoke "make" "-j8" "distcheck"
                       (format #f "DISTCHECK_CONFIGURE_FLAGS=SHELL=~a" (which "bash")))
@@ -242,7 +322,8 @@
 	   tar gzip global pkg-config
 	   texinfo (texlive-updmap.cfg (list texlive))
            perl gnulib gtk check (list glib "bin")
-           gobject-introspection imagemagick))
+           gobject-introspection imagemagick
+           indent cppi))
     (inputs
      (list gtk libadwaita check gnu-gettext))
     (home-page "https://labo.planete-kraus.eu/disfluid.git")