guix: import texlive: Propagate binaries when necessary.

* guix/import/texlive.scm (no-bin-propagation-packages): New variable.
(list-binfiles): New function.
(linked-scripts): Renamed to...
(list-linked-scripts): ... this.  Now always return a list.
(tlpdb->package): Handle binary propagation.
* tests/texlive.scm (%fake-tlpdb): Add data for new tests.
("texlive->guix-package, propagated binaries, no script"):
("texlive->guix-package, propagated binaries and scripts"):
("texlive->guix-package, with skipped propagated binaries"): New tests.

Change-Id: I707ba33a10aa98ad27151724d3ecc4158db6b7cc

2 files changed, 193 insertions, 32 deletions

diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm
index 7e79c77884..20dedc9114 100644
--- a/guix/import/texlive.scm
+++ b/guix/import/texlive.scm
@@ -64,6 +64,23 @@
         "tex/generic/hyphen/"
         "web2c/"))
 
+;; The following packages should propagate their binaries according to the TeX
+;; Live database, but won't because said binaries are already provided by
+;; "texlive-bin".  As a consequence, the importer does not make them propagate
+;; their "-bin" counterpart.
+(define no-bin-propagation-packages
+  (list "cweb"
+        "latex-bin"
+        "luahbtex"
+        "luatex"
+        "metafont"
+        "pdftex"
+        "pdftosrc"
+        "synctex"
+        "tex"
+        "tie"
+        "web"))
+
 (define string->license
   (match-lambda
     ("artistic2" 'artistic2.0)
@@ -296,33 +313,39 @@ When TEXLIVE-ONLY is true, only TeX Live packages are returned."
              ;; Get the right (alphabetic) order.
              (reverse actions))))))
 
-(define (linked-scripts name package-database)
+(define (list-binfiles name package-database)
+  "Return the list of \"binfiles\", i.e., files meant to be installed in
+\"bin/\" directory, for package NAME according to PACKAGE-DATABASE."
+  (or (and-let* ((data (assoc-ref package-database name))
+                 (depend (assoc-ref data 'depend))
+                 ((member (string-append name ".ARCH") depend))
+                 (bin-data (assoc-ref package-database
+                                      ;; Any *nix-like architecture will do.
+                                      (string-append name ".x86_64-linux"))))
+        (map basename (assoc-ref bin-data 'binfiles)))
+      '()))
+
+(define (list-linked-scripts name package-database)
   "Return a list of script names to symlink from \"bin/\" directory for
 package NAME according to PACKAGE-DATABASE.  Consider as scripts files with
 \".lua\", \".pl\", \".py\", \".rb\", \".sh\", \".tcl\", \".texlua\", \".tlu\"
 extensions, and files without extension."
-  (and-let* ((data (assoc-ref package-database name))
-             ;; Check if binaries are associated to the package.
-             (depend (assoc-ref data 'depend))
-             ((member (string-append name ".ARCH") depend))
-             ;; List those binaries.
-             (bin-data (assoc-ref package-database
-                                  ;; Any *nix-like architecture will do.
-                                  (string-append name ".x86_64-linux")))
-             (binaries (map basename (assoc-ref bin-data 'binfiles)))
-             ;; List scripts candidates.  Bail out if there are none.
-             (runfiles (assoc-ref data 'runfiles))
-             (scripts (filter (cut string-prefix? "texmf-dist/scripts/" <>)
-                              runfiles))
-             ((pair? scripts)))
-    (filter-map (lambda (script)
-                  (and (any (lambda (ext)
-                              (member (basename script ext) binaries))
-                            '(".lua" ".pl" ".py" ".rb" ".sh" ".tcl" ".texlua"
-                              ".tlu"))
-                       (basename script)))
-                ;; Get the right (alphabetic) order.
-                (reverse scripts))))
+  (or (and-let* ((data (assoc-ref package-database name))
+                 ;; List scripts candidates.  Bail out if there are none.
+                 (runfiles (assoc-ref data 'runfiles))
+                 (scripts (filter (cut string-prefix? "texmf-dist/scripts/" <>)
+                                  runfiles))
+                 ((pair? scripts))
+                 (binfiles (list-binfiles name package-database)))
+        (filter-map (lambda (script)
+                      (and (any (lambda (ext)
+                                  (member (basename script ext) binfiles))
+                                '(".lua" ".pl" ".py" ".rb" ".sh" ".tcl" ".texlua"
+                                  ".tlu"))
+                           (basename script)))
+                    ;; Get the right (alphabetic) order.
+                    (reverse scripts)))
+      '()))
 
 (define* (files-differ? directory package-name
                         #:key
@@ -408,7 +431,20 @@ of those files are returned that are unexpectedly installed."
              (source (with-store store
                        (download-multi-svn-to-store
                         store ref (string-append name "-svn-multi-checkout")))))
-    (let* ((scripts (linked-scripts texlive-name package-database))
+    (let* ((scripts (list-linked-scripts texlive-name package-database))
+           (propagated-inputs
+            (let ((binfiles (list-binfiles texlive-name package-database)))
+              (sort (append
+                     ;; Check if propagation of binaries is necessary.  It
+                     ;; happens when binfiles outnumber the scripts, if any.
+                     (if (and (> (length binfiles) (length scripts))
+                              (not (member texlive-name
+                                           no-bin-propagation-packages)))
+                         (list (string-append name "-bin"))
+                         '())
+                     ;; Regular dependencies, as specified in database.
+                     (map guix-name (translate-depends depends)))
+                    string<?)))
            (tex-formats (formats data))
            (meta-package? (null? locs))
            (empty-package? (and meta-package? (not (pair? tex-formats)))))
@@ -481,16 +517,14 @@ of those files are returned that are unexpectedly installed."
                                        ((string-suffix? ".rb" s) '(ruby))
                                        ((string-suffix? ".tcl" s) '(tcl tk))
                                        (else '())))
-                               (or scripts '()))
+                               scripts)
               (() '())
               (inputs `((inputs (list ,@(delete-duplicates inputs eq?))))))
           ;; Propagated inputs.
-          ,@(match (translate-depends depends)
+          ,@(match (map string->symbol propagated-inputs)
               (() '())
-              (inputs
-               `((propagated-inputs
-                  (list ,@(map (compose string->symbol guix-name)
-                               (sort inputs string<?)))))))
+              (inputs `((propagated-inputs (list ,@inputs)))))
+          ;; Home page, synopsis, description and license.
           (home-page
            ,(cond
              (meta-package? "https://www.tug.org/texlive/")
@@ -505,6 +539,7 @@ of those files are returned that are unexpectedly installed."
               '(fsf-free "https://www.tug.org/texlive/copying.html"))
              ((assoc-ref data 'catalogue-license) => string->license)
              (else #f))))
+       ;; List of pure TeX Live dependencies for recursive calls.
        (translate-depends depends #t)))))
 
 (define texlive->guix-package
diff --git a/tests/texlive.scm b/tests/texlive.scm
index fac9faf714..bfd3f57f20 100644
--- a/tests/texlive.scm
+++ b/tests/texlive.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017, 2022 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2023 Nicolas Goaziou <mail@nicolasgoaziou.fr>
+;;; Copyright © 2023, 2024 Nicolas Goaziou <mail@nicolasgoaziou.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -162,6 +162,16 @@
       "texmf-dist/tex/lollipop/lollipop.ini"
       "texmf-dist/tex/lollipop/lollipop.tex")
      (catalogue-license . "gpl3"))
+    ("m-tx"
+     (name . "m-tx")
+     (shortdesc . "A preprocessor for pmx")
+     (longdesc . "M-Tx is a preprocessor to pmx")
+     (depend "m-tx.ARCH")
+     (runfiles "texmf-dist/scripts/m-tx/m-tx.lua"))
+    ("m-tx.x86_64-linux"
+     (name . "m-tx.x86_64-linux")
+     (binfiles "bin/x86_64-linux/m-tx"
+               "bin/x86_64-linux/prepmx"))
     ("pax"
      (name . "pax")
      (shortdesc . "Extract and reinsert PDF...")
@@ -329,7 +339,22 @@ completely compatible with Plain TeX.")
                "texmf-dist/fonts/tfm/public/trsym/trsy12.tfm"
                "texmf-dist/tex/latex/trsym/trsym.sty"
                "texmf-dist/tex/latex/trsym/utrsy.fd")
-     (catalogue-license . "lppl"))))
+     (catalogue-license . "lppl"))
+    ("vlna"
+     (name . "vlna")
+     (shortdesc . "Add ~ after non-syllabic preposition")
+     (longdesc . "Preprocessor for TeX source")
+     (depend "vlna.ARCH")
+     (docfiles "texmf-dist/doc/man/man1/vlna.1"))
+    ("vlna.x86_64-linux"
+     (shortdesc "x86_64-linux files of vlna")
+     (binfiles "bin/x86_64-linux/vlna"))
+    ("web"
+     (depend "web.ARCH")
+     (docfiles "texmf-dist/doc/man/man1/tangle.1"))
+    ("web.x86_64-linux"
+     (name . "web.x86_64-linux")
+     (binfiles "bin/x86_64-linux/tangle"))))
 
 (test-assert "texlive->guix-package, no docfiles"
   ;; Replace network resources with sample data.
@@ -798,4 +823,105 @@ completely compatible with Plain TeX.")
                (format #t "~s~%" result)
                (pk 'fail result #f)))))))
 
+(test-assert "texlive->guix-package, propagated binaries, no script"
+  ;; Replace network resources with sample data.
+  (mock ((guix build svn) svn-fetch
+         (lambda* (url revision directory
+                       #:key (svn-command "svn")
+                       (user-name #f)
+                       (password #f)
+                       (recursive? #t))
+           (mkdir-p directory)
+           (with-output-to-file (string-append directory "/foo")
+             (lambda ()
+               (display "source")))))
+        (let ((result (texlive->guix-package "vlna"
+                                             #:package-database
+                                             (lambda _ %fake-tlpdb))))
+          (match result
+            (('package
+               ('name "texlive-vlna")
+               ('version _)
+               ('source _)
+               ('outputs _)
+               ('build-system 'texlive-build-system)
+               ('propagated-inputs
+                ('list 'texlive-vlna-bin))
+               ('home-page _)
+               ('synopsis _)
+               ('description _)
+               ('license _))
+             #true)
+            (_
+             (begin
+               (format #t "~s~%" result)
+               (pk 'fail result #f)))))))
+
+(test-assert "texlive->guix-package, propagated binaries and scripts"
+  ;; Replace network resources with sample data.
+  (mock ((guix build svn) svn-fetch
+         (lambda* (url revision directory
+                       #:key (svn-command "svn")
+                       (user-name #f)
+                       (password #f)
+                       (recursive? #t))
+           (mkdir-p directory)
+           (with-output-to-file (string-append directory "/foo")
+             (lambda ()
+               (display "source")))))
+        (let ((result (texlive->guix-package "m-tx"
+                                             #:package-database
+                                             (lambda _ %fake-tlpdb))))
+          (match result
+            (('package
+               ('name "texlive-m-tx")
+               ('version _)
+               ('source _)
+               ('build-system 'texlive-build-system)
+               ('arguments
+                ('list '#:link-scripts ('gexp ('list "m-tx.lua"))))
+               ('propagated-inputs
+                ('list 'texlive-m-tx-bin))
+               ('home-page _)
+               ('synopsis _)
+               ('description _)
+               ('license _))
+             #true)
+            (_
+             (begin
+               (format #t "~s~%" result)
+               (pk 'fail result #f)))))))
+
+(test-assert "texlive->guix-package, with skipped propagated binaries"
+  ;; Replace network resources with sample data.
+  (mock ((guix build svn) svn-fetch
+         (lambda* (url revision directory
+                       #:key (svn-command "svn")
+                       (user-name #f)
+                       (password #f)
+                       (recursive? #t))
+           (mkdir-p directory)
+           (with-output-to-file (string-append directory "/foo")
+             (lambda ()
+               (display "source")))))
+        (let ((result (texlive->guix-package "web"
+                                             #:package-database
+                                             (lambda _ %fake-tlpdb))))
+          (match result
+            (('package
+               ('name "texlive-web")
+               ('version _)
+               ('source _)
+               ('outputs _)
+               ('build-system 'texlive-build-system)
+               ('home-page _)
+               ('synopsis _)
+               ('description _)
+               ('license _))
+             #true)
+            (_
+             (begin
+               (format #t "~s~%" result)
+               (pk 'fail result #f)))))))
+
 (test-end "texlive")