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

[guix-commits]

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

commit d6461b4d92170db264fde947e20d826e7784af64
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.
    * guix/build-system/texlive.scm (texlive-build): Add 
#:IGNORE-METAFONT-FILES keyword.
    * doc/guix.texi (Build Systems): Mention new keyword in the
    TEXLIVE-BUILD-SYSTEM documentation.
---
 doc/guix.texi                       |   5 ++
 guix/build-system/texlive.scm       |   2 +
 guix/build/texlive-build-system.scm | 127 +++++++++++++++++++++++++++---------
 3 files changed, 102 insertions(+), 32 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index d317f0fd57..30677a7117 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -9755,6 +9755,11 @@ 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.  You may exclude some of these @file{.mf} from
+the process, for example those representing partial definitions, by
+passing their list to @code{#:ignore-metafont-files} argument.
+
 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-system/texlive.scm b/guix/build-system/texlive.scm
index 55e9cfee81..97041e2530 100644
--- a/guix/build-system/texlive.scm
+++ b/guix/build-system/texlive.scm
@@ -143,6 +143,7 @@ level package ID."
                         (phases '(@ (guix build texlive-build-system)
                                     %standard-phases))
                         (outputs '("out"))
+                        (ignore-metafont-files '())
                         (search-paths '())
                         (system (%current-system))
                         (guile #f)
@@ -171,6 +172,7 @@ level package ID."
                                               (sexp->gexp phases)
                                               phases)
                                #:outputs %outputs
+                               #:ignore-metafont-files '#$ignore-metafont-files
                                #:inputs %build-inputs
                                #:search-paths '#$(sexp->gexp
                                                   (map 
search-path-specification->sexp
diff --git a/guix/build/texlive-build-system.scm 
b/guix/build/texlive-build-system.scm
index 9bc0ce31c1..549bffd276 100644
--- a/guix/build/texlive-build-system.scm
+++ b/guix/build/texlive-build-system.scm
@@ -43,11 +43,101 @@
            (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 localization 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 ignore-metafont-files #:allow-other-keys)
+  (define (texlive-input? input)
+    (string-prefix? "texlive-" input))
+  (define (font-files directory)
+    (filter (lambda (f)
+              (not (member (basename f) ignore-metafont-files)))
+            (find-files directory "([0-9]+[^/]*?|inch)\\.mf$")))
+  (define (font-sources root)
+    (delete-duplicates (map dirname (font-files root))))
+  (let ((local-font-sources (font-sources "fonts/source")))
+    (unless (null? local-font-sources)
+      (let* ((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 to
+             ;; later make them visible to later tell "mf" when 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)))
+                           (or native-inputs inputs))))
+             (root (getcwd)))
+        ;; 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 ".")))
+           ;; Refresh font metrics at the appropriate location.
+           (install-as-runfiles "build" "\\.tfm$"))
+         local-font-sources)))))
+
 (define (compile-with-latex engine format output file)
   (invoke engine
           "-interaction=nonstopmode"
@@ -86,42 +176,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 +209,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)))