path: root/guix/import/texlive.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2021, 2022, 2023 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2024 Nicolas Goaziou <mail@nicolasgoaziou.fr>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix import texlive)
  #:use-module (gcrypt hash)
  #:use-module (guix base32)
  #:use-module (guix build-system texlive)
  #:use-module (guix derivations)
  #:use-module (guix gexp)
  #:use-module (guix import utils)
  #:use-module (guix memoization)
  #:use-module (guix monads)
  #:use-module (guix serialization)
  #:use-module (guix store)
  #:use-module (guix svn-download)
  #:use-module (guix upstream)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-2)
  #:use-module (srfi srfi-26)
  #:export (texlive->guix-package
            texlive-recursive-import))

;;; Commentary:
;;;
;;; Generate a package declaration template for corresponding package in the
;;; Tex Live Package Database (tlpdb).  We fetch all sources from different
;;; locations in the SVN repository of the Texlive project.
;;;
;;; Code:

;; Generic locations are parts of the tree shared by multiple packages.
;; Package definitions should single out files stored there, or all files in
;; the directory from all involved packages would be downloaded.
(define texlive-generic-locations
  (list "doc/info/"
        "doc/man/man1/"
        "doc/man/man5/"
        "doc/web2c/"
        "scripts/context/lua/"
        "scripts/context/perl/"
        "scripts/texlive/"
        "scripts/texlive-extra/"
        "tex/generic/config/"
        "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)
    ("apache2" 'asl2.0)
    ("gpl" 'gpl3+)
    ("gpl1" 'gpl1)
    ("gpl1+" 'gpl1+)
    ("gpl2" 'gpl2)
    ("gpl2+" 'gpl2+)
    ("gpl3" 'gpl3)
    ("gpl3+" 'gpl3+)
    ("lgpl2.1" 'lgpl2.1)
    ("lgpl3" 'lgpl3)
    ("knuth" 'knuth)
    ("pd" 'public-domain)
    ("bsd2" 'bsd-2)
    ("bsd3" 'bsd-3)
    ("bsd4" 'bsd-4)
    ("opl" 'opl1.0+)
    ("ofl" 'silofl1.1)

    ("lpplgpl" `(list lppl gpl1+))
    ("lppl" 'lppl)
    ("lppl1" 'lppl1.0+)                 ; usually means "or later"
    ("lppl1.2" 'lppl1.2+)               ; usually means "or later"
    ("lppl1.3" 'lppl1.3+)               ; usually means "or later"
    ("lppl1.3a" 'lppl1.3a)
    ("lppl1.3b" 'lppl1.3b)
    ("lppl1.3c" 'lppl1.3c)
    ("cc0" 'cc0)
    ("cc-by-2" 'cc-by2.0)
    ("cc-by-3" 'cc-by3.0)
    ("cc-by-4" 'cc-by4.0)
    ("cc-by-sa-2" 'cc-by-sa2.0)
    ("cc-by-sa-3" 'cc-by-sa3.0)
    ("cc-by-sa-4" 'cc-by-sa4.0)
    ("mit" 'expat)
    ("x11" 'x11)
    ("fdl" 'fdl1.3+)
    ;; The GUST Font Nosource License, which is legally equivalent to
    ;; lppl1.3c+, is no longer in use (per
    ;; <https://www.gust.org.pl/projects/e-foundry/licenses>).  It has de
    ;; facto become GUST Font License 1.0.
    ((or "gfl" "gfsl") 'gfl1.0)
    ("isc" 'isc)

    ;; These are known non-free licenses
    ("noinfo" 'unknown)
    ("nosell" 'non-free)
    ("shareware" 'non-free)
    ("nosource" 'non-free)
    ("nocommercial" 'non-free)
    ("cc-by-nc-nd-1" 'non-free)
    ("cc-by-nc-nd-2" 'non-free)
    ("cc-by-nc-nd-2.5" 'non-free)
    ("cc-by-nc-nd-3" 'non-free)
    ("cc-by-nc-nd-4" 'non-free)
    ((? string? x) (string->license (string-split x #\space)))
    ((x) `(error unknown-license ,x))
    ((lst ...) `(list ,@(map string->license lst)))
    (x `(error unknown-license ,x))))

(define (guix-name name)
  "Return a Guix package name for a given Texlive package NAME."
  (string-append "texlive-"
                 (string-map (match-lambda
                               (#\_ #\-)
                               (#\. #\-)
                               (chr (char-downcase chr)))
                             name)))

(define* (filter-depends depends #:optional texlive-only)
  "Filter upstream package names DEPENDS to include only their equivalent Guix
package names, without \"texlive-\" prefix.  When TEXLIVE-ONLY is true, ignore
Guix-specific packages."
  (delete-duplicates
   (filter-map (match-lambda
                 ;; Hyphenation.  Every TeX Live package is replaced with
                 ;; "hyphen-complete", unless "hyphen-base" is the sole
                 ;; dependency.
                 ("hyphen-base"
                  (and (not (member "hyph-utf8" depends))
                       "hyphen-base"))
                 ((or (? (cut string-prefix? "hyphen-" <>))
                      "hyph-utf8" "dehyph" "dehyph-exptl" "ruhyphen" "ukrhyph")
                  (and (not texlive-only) "hyphen-complete"))
                 ;; Binaries placeholders are ignored.
                 ((? (cut string-suffix? ".ARCH" <>)) #f)
                 ;; So are TeX Live specific packages.
                 ((or (? (cut string-prefix? "texlive-" <>))
                      "tlshell" "texlive.infra")
                  #f)
                 ;; And also development packages, which should inherit from
                 ;; the current package anyway.
                 ((? (cut string-suffix? "-dev" <>)) #f)
                 ;; Guix does not use Asymptote from TeX Live.  Ignore it.
                 ("asymptote" #f)
                 ;; TeXworks in TeX Live is only for Windows.  Don't bother.
                 ((or "texworks" "collection-texworks") #f)
                 ;; Others.
                 (name name))
               depends)))

(define (tlpdb-file)
  (define texlive-scripts
    ;; Resolve this variable lazily so that (gnu packages ...) does not end up
    ;; in the closure of this module.
    (module-ref (resolve-interface '(gnu packages tex))
                'texlive-scripts))

  (with-store store
    (run-with-store store
      (mlet* %store-monad
          ((drv (lower-object texlive-scripts))
           (built (built-derivations (list drv))))
        (match (derivation->output-paths drv)
          (((names . items) ...)
           (return (string-append (second items) ;"out"
                                  "/share/tlpkg/texlive.tlpdb"))))))))

(define tlpdb
  (memoize
   (lambda ()
     (let ((file (tlpdb-file))
           (fields
            '((name     . string)
              (shortdesc . string)
              (longdesc . string)
              (catalogue . string)
              (catalogue-license . string)
              (catalogue-ctan . string)
              (srcfiles . list)
              (runfiles . list)
              (docfiles . list)
              (binfiles . list)
              (depend   . simple-list)
              (execute  . simple-list)))
           (record
            (lambda* (key value alist #:optional (type 'string))
              (let ((new
                     (or (and=> (assoc-ref alist key)
                                (lambda (existing)
                                  (cond
                                   ((eq? type 'string)
                                    (string-append existing " " value))
                                   ((or (eq? type 'list) (eq? type 'simple-list))
                                    (cons value existing)))))
                         (cond
                          ((eq? type 'string)
                           value)
                          ((or (eq? type 'list) (eq? type 'simple-list))
                           (list value))))))
                (acons key new (alist-delete key alist))))))
       (call-with-input-file file
         (lambda (port)
           (let loop ((all (list))
                      (current (list))
                      (last-property #false))
             (let ((line (read-line port)))
               (cond
                ((eof-object? line) all)

                ;; End of record.
                ((string-null? line)
                 (loop (cons (cons (assoc-ref current 'name) current)
                             all)
                       (list) #false))

                ;; Continuation of a list
                ((and (zero? (string-index line #\space)) last-property)
                 ;; Erase optional second part of list values like
                 ;; "details=Readme" for files
                 (let ((plain-value (first
                                     (string-split
                                      (string-trim-both line) #\space))))
                   (loop all (record last-property
                                     plain-value
                                     current
                                     'list)
                         last-property)))
                (else
                 (or (and-let* ((space (string-index line #\space))
                                (key   (string->symbol (string-take line space)))
                                (value (string-drop line (1+ space)))
                                (field-type (assoc-ref fields key)))
                       ;; Erase second part of list keys like "size=29"
                       (cond
                        ((eq? field-type 'list)
                         (loop all current key))
                        (else
                         (loop all (record key value current field-type) key))))
                     (loop all current #false))))))))))))

(define latex-bin-dependency-tree
  ;; Return a list of packages used to build "latex-bin" package.  Those
  ;; cannot provide it as a native input.  Consequently, the importer sets
  ;; TEXLIVE-LATEX-BIN? argument to #F for all of them.
  (memoize
   (lambda (package-database)
     ;; Start out with "latex-bin", but also provide native inputs, which do
     ;; not appear as dependents, as roots for the search.
     (let loop ((packages
                 (list "latex-bin" "metafont" "modes" "tex"))
                (deps '()))
       (if (null? packages)
           ;; `filter-depends' will always translate "hyphen-base" into
           ;; "hyphen-complete".  Make sure plain hyphen-base appears in the
           ;; dependency tree.
           (cons "hyphen-base" (filter-depends deps))
           (loop (append-map (lambda (name)
                               (let ((data (assoc-ref package-database name)))
                                 (or (assoc-ref data 'depend)
                                     '())))
                             packages)
                 (append packages deps)))))))

(define (list-formats package-data)
  "Return a list of formats to build according to PACKAGE-DATA."
  (and=> (assoc-ref package-data 'execute)
         (lambda (actions)
           (delete-duplicates
            (filter-map
             (lambda (action)
               (match (string-split action #\space)
                 (("AddFormat" fmt . _)
                  (string-drop fmt (string-length "name=")))
                 (_ #f)))
             ;; Get the right (alphabetic) order.
             (reverse actions))))))

(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."
  (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 (list-upstream-inputs upstream-name)
  "Return the list of <upstream-input> corresponding to all the dependencies
of package with UPSTREAM-NAME."
  (let* ((database (tlpdb))
         (package-data (assoc-ref database upstream-name))
         (scripts (list-linked-scripts upstream-name database)))
    (append
     ;; Native inputs.
     ;;
     ;; Texlive build system generates font metrics whenever a font metrics
     ;; file has the same base name as a Metafont file.  In this case, provide
     ;; TEXLIVE-METAFONT.
     (or (and-let* ((runfiles (assoc-ref package-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)))
           (list (upstream-input
                  (name "metafont")
                  (downstream-name "texlive-metafont")
                  (type 'native))))
         '())
     ;; Regular inputs.
     ;;
     ;; Those may be required by scripts associated to the package.
     (match (append-map (lambda (s)
                          (cond ((string-suffix? ".pl" s) '("perl"))
                                ((string-suffix? ".py" s) '("python"))
                                ((string-suffix? ".rb" s) '("ruby"))
                                ((string-suffix? ".tcl" s) '("tcl" "tk"))
                                (else '())))
                        scripts)
       (() '())
       (inputs (map (lambda (input-name)
                      (upstream-input
                       (name input-name)
                       (downstream-name input-name)
                       (type 'regular)))
                    (delete-duplicates inputs string=))))
     ;; Propagated inputs.
     ;;
     ;; Return the "depend" references given in the TeX Live database.  Also
     ;; check if the package has associated binaries built from
     ;; TEXLIVE-SOURCE.  In that case, add a Guix-specific NAME-bin propagated
     ;; input.
     (let ((binfiles (list-binfiles upstream-name database)))
       (map (lambda (input-name)
              (upstream-input
               (name input-name)
               (downstream-name (guix-name input-name))
               (type 'propagated)))
            (sort (append
                   (filter-depends (or (assoc-ref package-data 'depend) '()))
                   ;; Check if propagation of binaries is necessary.  It
                   ;; happens when binfiles outnumber the scripts, if any.
                   (if (and (> (length binfiles) (length scripts))
                            (not (member upstream-name
                                         no-bin-propagation-packages)))
                       (list (string-append upstream-name "-bin"))
                       '()))
                  string<?))))))

(define (upstream-inputs->texlive-inputs upstream-inputs type)
  (map (compose string->symbol upstream-input-downstream-name)
       (filter (upstream-input-type-predicate type)
               upstream-inputs)))

(define (files->locations files)
  (define (trim-filename entry)
    (string-join (drop-right (string-split entry #\/) 1) "/" 'suffix))
  ;; Generic locations are shared by multiple packages.  Provide the full file
  ;; name to make so as to extract only the files related to the package being
  ;; imported.
  (let-values (((generic specific)
                (partition (lambda (f)
                             ;; Only grab files from generic locations, not
                             ;; sub-directories.
                             (any (cut string=? <> (trim-filename f))
                                  texlive-generic-locations))
                           files)))
    (append generic
            ;; Remove sub-directories, i.e., more specific entries with the
            ;; same prefix.
            (delete-duplicates (sort (map trim-filename specific) string<)
                               string-prefix?))))

(define (tlpdb->package name version package-database)
  (and-let* ((data (assoc-ref package-database name))
             (locs (files->locations
                    (filter-map (lambda (file)
                                  ;; Ignore any file not starting with the
                                  ;; expected prefix.  Nothing good can come
                                  ;; from this.
                                  (and (string-prefix? "texmf-dist/" file)
                                       (string-drop file (string-length "texmf-dist/"))))
                                (append (or (assoc-ref data 'docfiles) (list))
                                        (or (assoc-ref data 'runfiles) (list))
                                        (or (assoc-ref data 'srcfiles) (list))))))
             (texlive-name name)
             (name (guix-name name))
             ;; TODO: we're ignoring the VERSION argument because that
             ;; information is distributed across %texlive-tag and
             ;; %texlive-revision.
             (ref (svn-multi-reference
                   (url (string-append "svn://www.tug.org/texlive/tags/"
                                       %texlive-tag "/Master/texmf-dist"))
                   (locations locs)
                   (revision %texlive-revision)))
             ;; Ignore arch-dependent packages.
             (depends (or (assoc-ref data 'depend) '()))
             (source (with-store store
                       (download-multi-svn-to-store
                        store ref (string-append name "-svn-multi-checkout")))))
    (let* ((scripts (list-linked-scripts texlive-name package-database))
           (upstream-inputs (list-upstream-inputs texlive-name))
           (tex-formats (list-formats data))
           (meta-package? (null? locs))
           (empty-package? (and meta-package? (not (pair? tex-formats)))))
      (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")))
                '())
          ;; Set build-system.
          ;;
          ;; Use trivial build system only when the package contains no files,
          ;; and no TeX format file is expected to be built.
          (build-system ,(if empty-package?
                             'trivial-build-system
                             'texlive-build-system))
          ;; Generate arguments field.
          ,@(let* ((latex-bin-dependency?
                    (member texlive-name
                            (latex-bin-dependency-tree package-database)))
                   (arguments
                    (append (if empty-package?
                                '(#:builder #~(mkdir #$output))
                                '())
                            (if latex-bin-dependency?
                                '(#:texlive-latex-bin? #f)
                                '())
                            (if (pair? scripts)
                                `(#:link-scripts #~(list ,@scripts))
                                '())
                            (if (pair? tex-formats)
                                `(#:create-formats #~(list ,@tex-formats))
                                '()))))
              (if (pair? arguments)
                  `((arguments (list ,@arguments)))
                  '()))
          ;; Inputs.
          ,@(match (upstream-inputs->texlive-inputs upstream-inputs 'native)
              (() '())
              (inputs `((native-inputs (list ,@inputs)))))
          ,@(match (upstream-inputs->texlive-inputs upstream-inputs 'regular)
              (() '())
              (inputs `((inputs (list ,@inputs)))))
          ,@(match (upstream-inputs->texlive-inputs upstream-inputs 'regular)
              (() '())
              (inputs `((propagated-inputs (list ,@inputs)))))
          ;; Home page, synopsis, description and license.
          (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?
              '(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.
       (filter-depends depends #t)))))

(define texlive->guix-package
  (memoize
   (lambda* (name #:key
                  (version (number->string %texlive-revision))
                  (package-database tlpdb)
                  #:allow-other-keys)
     "Find the metadata for NAME in the tlpdb and return the `package'
s-expression corresponding to that package, or #f on failure."
     (tlpdb->package name version (package-database)))))

(define* (texlive-recursive-import name #:key repo version)
  (recursive-import name
                    #:repo repo
                    #:version version
                    #:repo->guix-package texlive->guix-package
                    #:guix-name guix-name))

;;; texlive.scm ends here