389/458: guix: texlive-build-system: Generate font metrics.

[guix-commits]

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

commit 1bc415567265f20b196db6f64642a4494590fe0e
Author: Nicolas Goaziou <mail@nicolasgoaziou.fr>
AuthorDate: Fri May 19 16:29:19 2023 +0200

    guix: texlive-build-system: Generate font metrics.
    
    * guix/build/texlive-build-system.scm (install-as-runfiles):
    (generate-font-metrics): New function.
    (build): Use INSTALL-AS-RUNFILES.
    (%standard-phases): Add new phase.
---
 doc/guix.texi                       |   3 +
 guix/build/texlive-build-system.scm | 138 +++++++++++++++++++++++++++---------
 2 files changed, 109 insertions(+), 32 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 02e4226d4a..0fd86242a9 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -9813,6 +9813,9 @@ and format can be specified with the @code{#:tex-format} 
argument.
 Different build targets can be specified with the @code{#:build-targets}
 argument, which expects a list of file names.
 
+It also generates font metrics (i.e., @file{.tfm} files) out of METAFONT
+files whenever possible.
+
 The build system adds only @code{texlive-bin} and
 @code{texlive-latex-base} (both from @code{(gnu packages tex}) to the
 inputs.  Both can be overridden with the arguments @code{#:texlive-bin}
diff --git a/guix/build/texlive-build-system.scm 
b/guix/build/texlive-build-system.scm
index 9bc0ce31c1..4f3938213f 100644
--- a/guix/build/texlive-build-system.scm
+++ b/guix/build/texlive-build-system.scm
@@ -27,6 +27,7 @@
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-26)
   #:export (%standard-phases
             texlive-build))
@@ -43,11 +44,111 @@
            (negate
             (cut member <> '("." ".." "build" "doc" "source")))))
 
+(define (install-as-runfiles dir regexp)
+  "Install files under DIR matching REGEXP on top of existing runfiles in the
+current tree.  Sub-directories below DIR are preserved when looking for the
+runfile to replace.  If a file has no matching runfile, it is ignored."
+  (let ((runfiles (append-map (cut find-files <>)
+                              (runfiles-root-directories))))
+    (for-each (lambda (file)
+                (match (filter
+                        (cut string-suffix?
+                             (string-drop file (string-length dir))
+                             <>)
+                        runfiles)
+                  ;; Current file is not a runfile.  Ignore it.
+                  (() #f)
+                  ;; One candidate only.  Replace it with the one from DIR.
+                  ((destination)
+                   (let ((target (dirname destination)))
+                     (install-file file target)
+                     (format #t "re-generated file ~s in ~s~%"
+                             (basename file)
+                             target)))
+                  ;; Multiple candidates!  Not much can be done.  Hopefully,
+                  ;; this should never happen.
+                  (_
+                   (format (current-error-port)
+                           "warning: ambiguous location for file ~s; ignoring 
it~%"
+                           (basename file)))))
+              (find-files dir regexp))))
+
 (define* (delete-drv-files #:rest _)
   "Delete pre-generated \".drv\" files in order to prevent build failures."
   (when (file-exists? "source")
     (for-each delete-file (find-files "source" "\\.drv$"))))
 
+(define* (generate-font-metrics #:key native-inputs inputs #:allow-other-keys)
+  ;; Decide what Metafont files to build by comparing them to the expected
+  ;; font metrics base names.  Keep only files for which the two base names
+  ;; do match.
+  (define (font-metrics root)
+    (and (file-exists? root)
+         (map (cut basename <> ".tfm") (find-files root "\\.tfm$"))))
+  (define (font-files directory metrics)
+    (if (file-exists? directory)
+        (delete-duplicates
+         (filter (lambda (f)
+                   (or (not metrics)
+                       (member (basename f ".mf") metrics)))
+                 (find-files directory "\\.mf$")))
+        '()))
+  ;; Metafont files could be scattered across multiple directories.  Treat
+  ;; each sub-directory as a separate font source.
+  (define (font-sources root metrics)
+    (delete-duplicates (map dirname (font-files root metrics))))
+  (define (texlive-input? input)
+    (string-prefix? "texlive-" input))
+  (and-let* ((local-metrics (font-metrics "fonts/tfm"))
+             (local-sources (font-sources "fonts/source" local-metrics))
+             ((not (null? local-sources))) ;nothing to generate: bail out
+             (root (getcwd))
+             (metafont
+              (cond ((assoc-ref (or native-inputs inputs) "texlive-metafont") 
=>
+                     (cut string-append <> "/share/texmf-dist"))
+                    (else
+                     (error "Missing 'texlive-metafont' native input"))))
+             ;; Collect all font source files from texlive (native-)inputs so
+             ;; "mf" can know where to look for them.
+             (font-inputs
+              (delete-duplicates
+               (append-map (match-lambda
+                             (((? (negate texlive-input?)) . _) '())
+                             (("texlive-bin" . _) '())
+                             (("texlive-metafont" . _)
+                              (list (string-append metafont "/metafont/base")))
+                             ((_ . input)
+                              (font-sources input #f)))
+                           (or native-inputs inputs)))))
+    ;; Tell mf where to find "mf.base".
+    (setenv "MFBASES" (string-append metafont "/web2c/"))
+    (mkdir-p "build")
+    (for-each
+     (lambda (source)
+       ;; Tell "mf" where are the font source files.  In case current package
+       ;; provides multiple sources, treat them separately.
+       (setenv "MFINPUTS"
+               (string-join (cons (string-append root "/" source)
+                                  font-inputs)
+                            ":"))
+       ;; Build font metrics (tfm).
+       (with-directory-excursion source
+         (for-each (lambda (font)
+                     (format #t "building font ~a~%" font)
+                     (invoke "mf" "-progname=mf"
+                             (string-append "-output-directory="
+                                            root "/build")
+                             (string-append "\\"
+                                            "mode:=ljfour; "
+                                            "mag:=1; "
+                                            "batchmode; "
+                                            "input "
+                                            (basename font ".mf"))))
+                   (font-files "." local-metrics)))
+       ;; Refresh font metrics at the appropriate location.
+       (install-as-runfiles "build" "\\.tfm$"))
+     local-sources)))
+
 (define (compile-with-latex engine format output file)
   (invoke engine
           "-interaction=nonstopmode"
@@ -86,42 +187,14 @@
                   targets))
       ;; Now move generated files from the "build" directory into the rest of
       ;; the source tree, effectively replacing downloaded files.
-
+      ;;
       ;; Documentation may have been generated, but replace only runfiles,
       ;; i.e., files that belong neither to "doc" nor "source" trees.
       ;;
       ;; In TeX Live, all packages are fully pre-generated.  As a consequence,
-      ;; a generated file from the "build" top directory absent from the rest
-      ;; of the tree is deemed unnecessary and can safely be ignored.
-      (let ((runfiles (append-map (cut find-files <>)
-                                  (runfiles-root-directories))))
-        (for-each (lambda (file)
-                    (match (filter
-                            (cut string-suffix?
-                                 (string-drop file (string-length "build"))
-                                 <>)
-                            runfiles)
-                      ;; Current file is not a runfile.  Ignore it.
-                      (() #f)
-                      ;; One candidate only.  Replace it with the one just
-                      ;; generated.
-                      ((destination)
-                       (let ((target (dirname destination)))
-                         (install-file file target)
-                         (format #t "re-generated file ~s in ~s~%"
-                                 (basename file)
-                                 target)))
-                      ;; Multiple candidates!  Not much can be done.
-                      ;; Hopefully, this should never happen.
-                      (_
-                       (format (current-error-port)
-                               "warning: ambiguous localization of file ~s; \
-ignoring it~%"
-                               (basename file)))))
-                  ;; Preserve the relative file name of the generated file in
-                  ;; order to be more accurate when looking for the
-                  ;; corresponding runfile in the tree.
-                  (find-files "build"))))))
+      ;; a generated file from the "build" top directory absent from the rest 
of
+      ;; the tree is deemed unnecessary and can safely be ignored.
+      (install-as-runfiles "build" "."))))
 
 (define* (install #:key outputs #:allow-other-keys)
   (let ((out (assoc-ref outputs "out"))
@@ -147,6 +220,7 @@ ignoring it~%"
     (delete 'bootstrap)
     (delete 'configure)
     (add-before 'build 'delete-drv-files delete-drv-files)
+    (add-after 'delete-drv-files 'generate-font-metrics generate-font-metrics)
     (replace 'build build)
     (delete 'check)
     (replace 'install install)))