;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Thiago Jung Bauermann <bauermann@kolabnow.com>
;;; Copyright © 2023 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 build texlive-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (guix build union)
  #:use-module (ice-9 format)
  #: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))

;; Commentary:
;;
;; Builder-side code of the standard build procedure for TeX Live packages.
;;
;; Code:

(define (runfiles-root-directories)
  "Return list of root directories containing runfiles."
  (scandir "."
           (negate
            (cut member <> '("." ".." "build" "doc" "source")))))

(define (texlive-input? input)
  "Return #t if INPUT is a texlive input, #f otherwise."
  (match input
    (((or "source" (? (cut string-prefix? "texlive-" <>))) . _) #t)
    (_ #f)))

(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* (patch-shell-scripts #:rest _)
  "Expand filenames for usual tools in shell scripts."
  (when (file-exists? "scripts")
    (let* ((commands '("awk" "basename" "cat" "grep" "mkdir" "rm" "sed" "sort"
                       "uname"))
           (command-regexp (format #f
                                   "\\b(~a)\\b"
                                   (string-join commands "|"))))
      (substitute* (find-files "scripts" "\\.sh$")
        ((command-regexp _ command)
         (which command))))))

(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))))
  (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* (create-formats #:key create-formats inputs #:allow-other-keys)
  (define (collect-locations inputs pred)
    (delete-duplicates
     (append-map (match-lambda
                   ((? (negate texlive-input?)) '())
                   ((_ . dir)
                    (if pred
                        (map dirname (find-files dir pred))
                        (list dir))))
                 inputs)))
  (when create-formats
    (setenv "TFMFONTS"
            (string-join (collect-locations inputs "\\.tfm$") ":"))
    (setenv "TEXINPUTS"
            (string-join (collect-locations inputs #f) "//:" 'suffix))
    (setenv "LUAINPUTS"
            (string-join (collect-locations inputs "\\.lua$") ":"))
    (mkdir-p "web2c")
    (for-each (cut invoke "fmtutil-sys" "--byfmt" <> "--fmtdir=web2c")
              create-formats)
    ;; Remove cruft.
    (for-each delete-file (find-files "web2c" "\\.log$"))))

(define (compile-with-latex engine format output file)
  (invoke engine
          "-interaction=nonstopmode"
          (string-append "-output-directory=" output)
          (if format (string-append "&" format) "-ini")
          file))

(define* (build #:key inputs build-targets tex-engine tex-format
                #:allow-other-keys)
  (let ((targets
         (cond
          (build-targets
           ;; Collect the relative file names of all the specified targets.
           (append-map (lambda (target)
                         (find-files "source"
                                     (lambda (f _)
                                       (string-suffix? (string-append "/" target)
                                                       f))))
                       build-targets))
          ((directory-exists? "source")
           ;; Prioritize ".ins" files over ".dtx" files.  There's no
           ;; scientific reasoning here; it just seems to work better.
           (match (find-files "source" "\\.ins$")
             (() (find-files "source" "\\.dtx$"))
             (files files)))
          (else '()))))
    (unless (null? targets)
      (let ((output (string-append (getcwd) "/build")))
        (mkdir-p output)
        (for-each (lambda (target)
                    (with-directory-excursion (dirname target)
                      (compile-with-latex tex-engine
                                          tex-format
                                          output
                                          (basename target))))
                  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.
      (install-as-runfiles "build" "."))))

(define* (install #:key outputs #:allow-other-keys)
  (let ((out (assoc-ref outputs "out"))
        (doc (assoc-ref outputs "doc")))
    ;; Take care of documentation.
    (when (directory-exists? "doc")
      (unless doc
        (format (current-error-port)
                "warning: missing 'doc' output for package documentation~%"))
      (let ((doc-dir (string-append (or doc out) "/share/texmf-dist/doc")))
        (mkdir-p doc-dir)
        (copy-recursively "doc" doc-dir)))
    ;; Install runfiles.  The package may not contain any, though.  Create
    ;; #$output anyway to handle this situation gracefully.
    (mkdir-p out)
    (let ((texmf (string-append out "/share/texmf-dist")))
      (for-each (lambda (root)
                  (let ((destination (string-append texmf "/" root)))
                    (mkdir-p destination)
                    (copy-recursively root destination)))
                (runfiles-root-directories)))))

(define* (link-scripts #:key link-scripts outputs #:allow-other-keys)
  (when (pair? link-scripts)
    (unless (file-exists? "scripts")
      (error "missing \"scripts\" directory: no script to link"))
    (let ((bin (string-append (assoc-ref outputs "out") "/bin"))
          (filenames
           (filter (lambda (f) (any (cut string-suffix? <> f) link-scripts))
                   (find-files "scripts"))))
      ;; Sanity check: make sure no provided script is ignored.
      (let ((unknown (lset-difference string=?
                                      (map basename link-scripts)
                                      (map basename filenames))))
        (when (pair? unknown)
          (error (format #f "cannot find script(s): ~a~%"
                         (string-join unknown)))))
      ;; All lights are green.  Create "bin/" and the symlinks.
      (mkdir-p bin)
      (for-each
       (lambda (script)
         ;; Remove extension, if any.
         (let ((name (match (string-split (basename script) #\.)
                       ((name) name)
                       (tokens (string-join (drop-right tokens 1)))))
               (origin (string-append "../share/texmf-dist/" script)))
           (format #t "linking bin/~s to ~s~%" name origin)
           (symlink origin (string-append bin "/" name))))
       filenames))))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (delete 'configure)
    (add-after 'unpack 'patch-shell-scripts patch-shell-scripts)
    (add-before 'build 'delete-drv-files delete-drv-files)
    (add-after 'delete-drv-files 'generate-font-metrics generate-font-metrics)
    (replace 'build build)
    (add-after 'build 'create-formats create-formats)
    (delete 'check)
    (replace 'install install)
    (add-after 'install 'link-scripts link-scripts)))

(define* (texlive-build #:key inputs (phases %standard-phases)
                        #:allow-other-keys #:rest args)
  "Build the given TeX Live package, applying all of PHASES in order."
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))

;;; texlive-build-system.scm ends here