413/458: guix: import: Improve importing texlive meta packages.

[guix-commits]

ngz pushed a commit to branch tex-team-next
in repository guix.

commit 4efaad4201daf53ed7eb75783b6188a86081fd90
Author: Nicolas Goaziou <mail@nicolasgoaziou.fr>
AuthorDate: Sat May 27 21:39:26 2023 +0200

    guix: import: Improve importing texlive meta packages.
    
    * guix/import/texlive.scm (tlpdb->package): Generate more appropriate 
source,
    home page and license fields when importing meta packages, i.e., TeX Live
    collections and schemes.
    * tests/texlive.scm (%fake-tlpdb): Add test data.
    ("texlive->guix-package, meta-package"): New test.
---
 guix/import/texlive.scm | 112 +++++++++++++++++++++++++-----------------------
 tests/texlive.scm       |  39 +++++++++++++++++
 2 files changed, 98 insertions(+), 53 deletions(-)

diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm
index 46680a0b6b..da58c8d13f 100644
--- a/guix/import/texlive.scm
+++ b/guix/import/texlive.scm
@@ -300,59 +300,65 @@ 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")))))
-    (values
-     `(package
-        (name ,name)
-        (version (number->string %texlive-revision))
-        (source (texlive-origin
-                 name version
-                 (list ,@(sort locs string<))
-                 (base32
-                  ,(bytevector->nix-base32-string
-                    (let-values (((port get-hash) (open-sha256-port)))
-                      (write-file source port)
-                      (force-output port)
-                      (get-hash))))))
-        ,@(if (assoc-ref data 'docfiles)
-              '((outputs '("out" "doc")))
-              '())
-        (build-system texlive-build-system)
-        ;; Texlive build system generates font metrics whenever a font metrics
-        ;; file has the same base name as a Metafont file.
-        ,@(or (and-let* ((runfiles (assoc-ref data 'runfiles))
-                         (metrics
-                          (filter-map (lambda (f)
-                                        (and (string-suffix? ".tfm" f)
-                                             (basename f ".tfm")))
-                                      runfiles))
-                         ((not (null? metrics)))
-                         ((any (lambda (f)
-                                 (and (string-suffix? ".mf" f)
-                                      (member (basename f ".mf") metrics)))
-                               runfiles)))
-                '((native-inputs (list texlive-metafont))))
-              '())
-        ,@(match filtered-depends
-            (() '())
-            (inputs
-             `((propagated-inputs
-                (list ,@(map
-                         (lambda (tex-name)
-                           (let ((name (guix-name tex-name)))
-                             (string->symbol name)))
-                         ;; Sort inputs alphabetically.
-                         (reverse inputs)))))))
-        (home-page
-         ,(or (and=> (or (assoc-ref data 'catalogue)
-                         (assoc-ref data 'name))
-                     (lambda (name)
-                       (string-append "https://ctan.org/pkg/"; name)))
-              "https://www.tug.org/texlive/";))
-        (synopsis ,(assoc-ref data 'shortdesc))
-        (description ,(and=> (assoc-ref data 'longdesc) beautify-description))
-        (license ,(and=> (assoc-ref data 'catalogue-license)
-                         string->license)))
-     filtered-depends)))
+    (let ((meta-package? (null? locs)))
+      (values
+       `(package
+          (name ,name)
+          (version (number->string %texlive-revision))
+          (source ,(and (not meta-package?)
+                        `(texlive-origin
+                          name version
+                          (list ,@(sort locs string<))
+                          (base32
+                           ,(bytevector->nix-base32-string
+                             (let-values (((port get-hash) (open-sha256-port)))
+                               (write-file source port)
+                               (force-output port)
+                               (get-hash)))))))
+          ,@(if (assoc-ref data 'docfiles)
+                '((outputs '("out" "doc")))
+                '())
+          (build-system texlive-build-system)
+          ;; Texlive build system generates font metrics whenever a font
+          ;; metrics file has the same base name as a Metafont file.
+          ,@(or (and-let* ((runfiles (assoc-ref data 'runfiles))
+                           (metrics
+                            (filter-map (lambda (f)
+                                          (and (string-suffix? ".tfm" f)
+                                               (basename f ".tfm")))
+                                        runfiles))
+                           ((not (null? metrics)))
+                           ((any (lambda (f)
+                                   (and (string-suffix? ".mf" f)
+                                        (member (basename f ".mf") metrics)))
+                                 runfiles)))
+                  '((native-inputs (list texlive-metafont))))
+                '())
+          ,@(match filtered-depends
+              (() '())
+              (inputs
+               `((propagated-inputs
+                  (list ,@(filter-map
+                           (lambda (tex-name)
+                             (let ((name (guix-name tex-name)))
+                               (string->symbol name)))
+                           ;; Sort inputs alphabetically.
+                           (reverse inputs)))))))
+          (home-page
+           ,(cond
+             (meta-package? "https://www.tug.org/texlive/";)
+             ((or (assoc-ref data 'catalogue) (assoc-ref data 'name)) =>
+              (cut string-append "https://ctan.org/pkg/"; <>))
+             (else "https://www.tug.org/texlive/";)))
+          (synopsis ,(assoc-ref data 'shortdesc))
+          (description ,(and=> (assoc-ref data 'longdesc) 
beautify-description))
+          (license
+           ,(cond
+             (meta-package?
+              '(license:fsf-free "https://www.tug.org/texlive/copying.html";))
+             ((assoc-ref data 'catalogue-license) => string->license)
+             (else #f))))
+       filtered-depends))))
 
 (define texlive->guix-package
   (memoize
diff --git a/tests/texlive.scm b/tests/texlive.scm
index 704c86e24a..4172262fb2 100644
--- a/tests/texlive.scm
+++ b/tests/texlive.scm
@@ -62,6 +62,11 @@
          .
          ("texmf-dist/tex/latex/chs-physics-report/chs-physics-report.sty"))
         (catalogue-license . "pd cc-by-sa-3")))
+    ("collection-texworks"
+     (name . "collection-texworks")
+     (shortdesc . "TeXworks editor...")
+     (longdesc . "See http...")
+     (depend "texworks" "collection-basic"))
     ("example"
      . ((name . "example")
         (shortdesc . "Typeset examples...")
@@ -401,4 +406,38 @@ completely compatible with Plain TeX.")
                (format #t "~s~%" result)
                (pk 'fail result #f)))))))
 
+(test-assert "texlive->guix-package, meta-package"
+  ;; 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 "collection-texworks"
+                                             #:package-database
+                                             (lambda _ %fake-tlpdb))))
+          (match result
+            (('package
+               ('name "texlive-collection-texworks")
+               ('version _)
+               ('source #f)
+               ('build-system 'texlive-build-system)
+               ('propagated-inputs
+                ('list 'texlive-collection-basic 'texlive-texworks))
+               ('home-page "https://www.tug.org/texlive/";)
+               ('synopsis (? string?))
+               ('description (? string?))
+               ('license
+                ('license:fsf-free 
"https://www.tug.org/texlive/copying.html";)))
+             #true)
+            (_
+             (begin
+               (format #t "~s~%" result)
+               (pk 'fail result #f)))))))
+
 (test-end "texlive")