[jackhill/guix/guix.git] / doc / build.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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/>.


;; This file contains machinery to build HTML and PDF copies of the manual
;; that can be readily published on the web site.  To do that, run:
;;
;;  guix build -f build.scm
;;
;; The result is a directory hierarchy that can be used as the manual/
;; sub-directory of the web site.

(use-modules (guix)
             (guix gexp)
             (guix git)
             (guix git-download)
             (git)
             (gnu packages base)
             (gnu packages gawk)
             (gnu packages gettext)
             (gnu packages guile)
             (gnu packages iso-codes)
             (gnu packages texinfo)
             (gnu packages tex)
             (srfi srfi-19)
             (srfi srfi-71))

(define file-append*
  (@@ (guix self) file-append*))

(define translated-texi-manuals
  (@@ (guix self) translate-texi-manuals))

(define info-manual
  (@@ (guix self) info-manual))

(define %languages
  '("de" "en" "es" "fr" "ru" "zh_CN"))

(define (texinfo-manual-images source)
  "Return a directory containing all the images used by the user manual, taken
from SOURCE, the root of the source tree."
  (define graphviz
    (module-ref (resolve-interface '(gnu packages graphviz))
                'graphviz))

  (define images
    (file-append* source "doc/images"))

  (define build
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils)
                       (srfi srfi-26))

          (define (dot->image dot-file format)
            (invoke #+(file-append graphviz "/bin/dot")
                    "-T" format "-Gratio=.9" "-Gnodesep=.005"
                    "-Granksep=.00005" "-Nfontsize=9"
                    "-Nheight=.1" "-Nwidth=.1"
                    "-o" (string-append #$output "/"
                                        (basename dot-file ".dot")
                                        "." format)
                    dot-file))

          ;; Build graphs.
          (mkdir-p #$output)
          (for-each (lambda (dot-file)
                      (for-each (cut dot->image dot-file <>)
                                '("png" "pdf")))
                    (find-files #$images "\\.dot$"))

          ;; Copy other PNGs.
          (for-each (lambda (png-file)
                      (install-file png-file #$output))
                    (find-files #$images "\\.png$")))))

  (computed-file "texinfo-manual-images" build))

(define* (texinfo-manual-source source #:key
                                (version "0.0")
                                (languages %languages)
                                (date 1))
  "Gather all the source files of the Texinfo manuals from SOURCE--.texi file
as well as images, OS examples, and translations."
  (define documentation
    (file-append* source "doc"))

  (define examples
    (file-append* source "gnu/system/examples"))

  (define build
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils)
                       (srfi srfi-19))

          (define (make-version-texi language)
            ;; Create the 'version.texi' file for LANGUAGE.
            (let ((file (if (string=? language "en")
                            "version.texi"
                            (string-append "version-" language ".texi"))))
              (call-with-output-file (string-append #$output "/" file)
                (lambda (port)
                  (let* ((version #$version)
                         (time    (make-time time-utc 0 #$date))
                         (date    (time-utc->date time)))
                    (format port "
@set UPDATED ~a
@set UPDATED-MONTH ~a
@set EDITION ~a
@set VERSION ~a\n"
                            (date->string date "~e ~B ~Y")
                            (date->string date "~B ~Y")
                            version version))))))

          (install-file #$(file-append* documentation "/htmlxref.cnf")
                        #$output)

          (for-each (lambda (texi)
                      (install-file texi #$output))
                    (append (find-files #$documentation "\\.(texi|scm)$")
                            (find-files #$(translated-texi-manuals source)
                                        "\\.texi$")))

          ;; Create 'version.texi'.
          (for-each make-version-texi '#$languages)

          ;; Copy configuration templates that the manual includes.
          (for-each (lambda (template)
                      (copy-file template
                                 (string-append
                                  #$output "/os-config-"
                                  (basename template ".tmpl")
                                  ".texi")))
                    (find-files #$examples "\\.tmpl$"))

          (symlink #$(texinfo-manual-images source)
                   (string-append #$output "/images")))))

  (computed-file "texinfo-manual-source" build))

(define %web-site-url
  ;; URL of the web site home page.
  (or (getenv "GUIX_WEB_SITE_URL")
      "/software/guix/"))

(define %makeinfo-html-options
  ;; Options passed to 'makeinfo --html'.
  '("--css-ref=https://www.gnu.org/software/gnulib/manual.css"))

(define* (html-manual source #:key (languages %languages)
                      (version "0.0")
                      (manual "guix")
                      (date 1)
                      (options %makeinfo-html-options))
  "Return the HTML manuals built from SOURCE for all LANGUAGES, with the given
makeinfo OPTIONS."
  (define manual-source
    (texinfo-manual-source source
                           #:version version
                           #:languages languages
                           #:date date))

  (define images
    (texinfo-manual-images source))

  (define build
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils)
                       (ice-9 match))

          (define (normalize language)
            ;; Normalize LANGUAGE.  For instance, "zh_CN" becomes "zh-cn".
            (string-map (match-lambda
                          (#\_ #\-)
                          (chr chr))
                        (string-downcase language)))

          ;; Install a UTF-8 locale so that 'makeinfo' is at ease.
          (setenv "GUIX_LOCPATH"
                  #+(file-append glibc-utf8-locales "/lib/locale"))
          (setenv "LC_ALL" "en_US.utf8")

          (setvbuf (current-output-port) 'line)
          (setvbuf (current-error-port) 'line)

          (for-each (lambda (language)
                      (let ((opts `("--html"
                                    "-c" ,(string-append "TOP_NODE_UP_URL=/manual/"
                                                         language)
                                    #$@options
                                    ,(if (string=? language "en")
                                         (string-append #$manual-source "/"
                                                        #$manual ".texi")
                                         (string-append #$manual-source "/"
                                                        #$manual "." language ".texi")))))
                        (format #t "building HTML manual for language '~a'...~%"
                                language)
                        (mkdir-p (string-append #$output "/"
                                                (normalize language)))
                        (setenv "LANGUAGE" language)
                        (apply invoke #$(file-append texinfo "/bin/makeinfo")
                               "-o" (string-append #$output "/"
                                                   (normalize language)
                                                   "/html_node")
                               opts)
                        (apply invoke #$(file-append texinfo "/bin/makeinfo")
                               "--no-split"
                               "-o"
                               (string-append #$output "/"
                                              (normalize language)
                                              "/" #$manual
                                              (if (string=? language "en")
                                                  ""
                                                  (string-append "." language))
                                              ".html")
                               opts)

                        ;; Make sure images are available.
                        (symlink #$images
                                 (string-append #$output "/" (normalize language)
                                                "/images"))
                        (symlink #$images
                                 (string-append #$output "/" (normalize language)
                                                "/html_node/images"))))
                    '#$languages))))

  (computed-file (string-append manual "-html-manual") build))

(define* (pdf-manual source #:key (languages %languages)
                     (version "0.0")
                     (manual "guix")
                     (date 1)
                     (options '()))
  "Return the HTML manuals built from SOURCE for all LANGUAGES, with the given
makeinfo OPTIONS."
  (define manual-source
    (texinfo-manual-source source
                           #:version version
                           #:languages languages
                           #:date date))

  ;; FIXME: This union works, except for the table of contents of non-English
  ;; manuals, which contains escape sequences like "^^ca^^fe" instead of
  ;; accented letters.
  ;;
  ;; (define texlive
  ;;   (texlive-union (list texlive-tex-texinfo
  ;;                        texlive-generic-epsf
  ;;                        texlive-fonts-ec)))

  (define build
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils)
                       (srfi srfi-34)
                       (ice-9 match))

          (define (normalize language)            ;XXX: deduplicate
            ;; Normalize LANGUAGE.  For instance, "zh_CN" becomes "zh-cn".
            (string-map (match-lambda
                          (#\_ #\-)
                          (chr chr))
                        (string-downcase language)))

          ;; Install a UTF-8 locale so that 'makeinfo' is at ease.
          (setenv "GUIX_LOCPATH"
                  #+(file-append glibc-utf8-locales "/lib/locale"))
          (setenv "LC_ALL" "en_US.utf8")
          (setenv "PATH"
                  (string-append #+(file-append texlive "/bin") ":"
                                 #+(file-append texinfo "/bin") ":"

                                 ;; Below are command-line tools needed by
                                 ;; 'texi2dvi' and friends.
                                 #+(file-append sed "/bin") ":"
                                 #+(file-append grep "/bin") ":"
                                 #+(file-append coreutils "/bin") ":"
                                 #+(file-append gawk "/bin") ":"
                                 #+(file-append tar "/bin") ":"
                                 #+(file-append diffutils "/bin")))

          (setvbuf (current-output-port) 'line)
          (setvbuf (current-error-port) 'line)

          (setenv "HOME" (getcwd))                ;for kpathsea/mktextfm

          ;; 'SOURCE_DATE_EPOCH' is honored by pdftex.
          (setenv "SOURCE_DATE_EPOCH" "1")

          (for-each (lambda (language)
                      (let ((opts `("--pdf"
                                    "-I" "."
                                    #$@options
                                    ,(if (string=? language "en")
                                         (string-append #$manual-source "/"
                                                        #$manual ".texi")
                                         (string-append #$manual-source "/"
                                                        #$manual "." language ".texi")))))
                        (format #t "building PDF manual for language '~a'...~%"
                                language)
                        (mkdir-p (string-append #$output "/"
                                                (normalize language)))
                        (setenv "LANGUAGE" language)


                        ;; FIXME: Unfortunately building PDFs for non-Latin
                        ;; alphabets doesn't work:
                        ;; <https://lists.gnu.org/archive/html/help-texinfo/2012-01/msg00014.html>.
                        (guard (c ((invoke-error? c)
                                   (format (current-error-port)
                                           "~%~%Failed to produce \
PDF for language '~a'!~%~%"
                                           language)))
                         (apply invoke #$(file-append texinfo "/bin/makeinfo")
                                "--pdf" "-o"
                                (string-append #$output "/"
                                               (normalize language)
                                               "/" #$manual
                                               (if (string=? language "en")
                                                   ""
                                                   (string-append "."
                                                                  language))
                                               ".pdf")
                                opts))))
                    '#$languages))))

  (computed-file (string-append manual "-pdf-manual") build))

(define (guix-manual-text-domain source languages)
  "Return the PO files for LANGUAGES of the 'guix-manual' text domain taken
from SOURCE."
  (define po-directory
    (file-append* source "/po/doc"))

  (define build
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils))

          (mkdir-p #$output)
          (for-each (lambda (language)
                      (define directory
                        (string-append #$output "/" language
                                       "/LC_MESSAGES"))

                      (mkdir-p directory)
                      (invoke #+(file-append gnu-gettext "/bin/msgfmt")
                              "-c" "-o"
                              (string-append directory "/guix-manual.mo")
                              (string-append #$po-directory "/guix-manual."
                                             language ".po")))
                    '#$(delete "en" languages)))))

  (computed-file "guix-manual-po" build))

(define* (html-manual-indexes source
                              #:key (languages %languages)
                              (version "0.0")
                              (manual "guix")
                              (date 1))
  (define build
    (with-extensions (list guile-json-3)
      (with-imported-modules '((guix build utils))
        #~(begin
            (use-modules (guix build utils)
                         (json)
                         (ice-9 match)
                         (ice-9 popen)
                         (sxml simple)
                         (srfi srfi-1)
                         (srfi srfi-19))

            (define (normalize language)          ;XXX: deduplicate
              ;; Normalize LANGUAGE.  For instance, "zh_CN" becomes "zh-cn".
              (string-map (match-lambda
                            (#\_ #\-)
                            (chr chr))
                          (string-downcase language)))

            (define-syntax-rule (with-language language exp ...)
              (let ((lang (getenv "LANGUAGE")))
                (dynamic-wind
                  (lambda ()
                    (setenv "LANGUAGE" language)
                    (setlocale LC_MESSAGES))
                  (lambda () exp ...)
                  (lambda ()
                    (if lang
                        (setenv "LANGUAGE" lang)
                        (unsetenv "LANGUAGE"))
                    (setlocale LC_MESSAGES)))))

            ;; (put 'with-language 'scheme-indent-function 1)
            (define* (translate str language
                                #:key (domain "guix-manual"))
              (define exp
                `(begin
                   (bindtextdomain "guix-manual"
                                   #+(guix-manual-text-domain
                                      source
                                      languages))
                   (bindtextdomain "iso_639-3"    ;language names
                                   #+(file-append iso-codes
                                                  "/share/locale"))
                   (write (gettext ,str ,domain))))

              (with-language language
                ;; Since the 'gettext' function caches msgid translations,
                ;; regardless of $LANGUAGE, we have to spawn a new process each
                ;; time we want to translate to a different language.  Bah!
                (let* ((pipe (open-pipe* OPEN_READ
                                         #+(file-append guile-2.2
                                                        "/bin/guile")
                                         "-c" (object->string exp)))
                       (str  (read pipe)))
                  (close-pipe pipe)
                  str)))

            (define (seconds->string seconds language)
              (let* ((time (make-time time-utc 0 seconds))
                     (date (time-utc->date time)))
                (with-language language (date->string date "~e ~B ~Y"))))

            (define (guix-url path)
              (string-append #$%web-site-url path))

            (define (sxml-index language title body)
              ;; FIXME: Avoid duplicating styling info from guix-artwork.git.
              `(html (@ (lang ,language))
                     (head
                      (title ,(string-append title " — GNU Guix"))
                      (meta (@ (charset "UTF-8")))
                      (meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
                      ;; Menu prefetch.
                      (link (@ (rel "prefetch") (href ,(guix-url "menu/index.html"))))
                      ;; Base CSS.
                      (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/elements.css"))))
                      (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/common.css"))))
                      (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/messages.css"))))
                      (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/navbar.css"))))
                      (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/breadcrumbs.css"))))
                      (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/buttons.css"))))
                      (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/footer.css"))))

                      (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/page.css"))))
                      (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/post.css")))))
                     (body
                      (header (@ (class "navbar"))
                              (h1 (a (@ (class "branding")
                                        (href #$%web-site-url)))
                                  (span (@ (class "a11y-offset"))
                                        "Guix"))
                              (nav (@ (class "menu"))))
                      (nav (@ (class "breadcrumbs"))
                           (a (@ (class "crumb")
                                 (href #$%web-site-url))
                              "Home"))
                      ,body
                      (footer))))

            (define (language-index language)
              (define title
                (translate "GNU Guix Reference Manual" language))

              (sxml-index
               language title
               `(main
                 (article
                  (@ (class "page centered-block limit-width"))
                  (h2 ,title)
                  (p (@ (class "post-metadata centered-text"))
                     #$version " — "
                     ,(seconds->string #$date language))

                  (div
                   (ul
                    (li (a (@ (href "html_node"))
                           "HTML, with one page per node"))
                    (li (a (@ (href
                               ,(string-append
                                 #$manual
                                 (if (string=? language
                                               "en")
                                     ""
                                     (string-append "."
                                                    language))
                                 ".html")))
                           "HTML, entirely on one page"))
                    ,@(if (member language '("ru" "zh_CN"))
                          '()
                          `((li (a (@ (href ,(string-append
                                              #$manual
                                              (if (string=? language "en")
                                                  ""
                                                  (string-append "."
                                                                 language))
                                              ".pdf"))))
                                "PDF")))))))))

            (define %iso639-languages
              (vector->list
               (assoc-ref (call-with-input-file
                              #+(file-append iso-codes
                                             "/share/iso-codes/json/iso_639-3.json")
                            json->scm)
                          "639-3")))

            (define (language-code->name code)
              "Return the full name of a language from its ISO-639-3 code."
              (let ((code (match (string-index code #\_)
                            (#f    code)
                            (index (string-take code index)))))
               (any (lambda (language)
                      (and (string=? (or (assoc-ref language "alpha_2")
                                         (assoc-ref language "alpha_3"))
                                     code)
                           (assoc-ref language "name")))
                    %iso639-languages)))

            (define (top-level-index languages)
              (define title
                "GNU Guix Reference Manual")
              (sxml-index
               "en" title
               `(main
                 (article
                  (@ (class "page centered-block limit-width"))
                  (h2 ,title)
                  (div
                   "The GNU Guix Reference Manual is available in the following
languages:\n"
                   (ul
                    ,@(map (lambda (language)
                             `(li (a (@ (href ,(normalize language)))
                                     ,(translate
                                       (language-code->name language)
                                       language
                                       #:domain "iso_639-3"))))
                           languages)))))))

            (define (write-html file sxml)
              (call-with-output-file file
                (lambda (port)
                  (display "<!DOCTYPE html>\n" port)
                  (sxml->xml sxml port))))

            (setenv "GUIX_LOCPATH"
                    #+(file-append glibc-utf8-locales "/lib/locale"))
            (setenv "LC_ALL" "en_US.utf8")
            (setlocale LC_ALL "en_US.utf8")

            (for-each (lambda (language)
                        (define directory
                          (string-append #$output "/"
                                         (normalize language)))

                        (mkdir-p directory)
                        (write-html (string-append directory "/index.html")
                                    (language-index language)))
                      '#$languages)

            (write-html (string-append #$output "/index.html")
                        (top-level-index '#$languages))))))

  (computed-file "html-indexes" build))

(define* (pdf+html-manual source
                          #:key (languages %languages)
                          (version "0.0")
                          (date (time-second (current-time time-utc)))
                          (manual "guix"))
  "Return the union of the HTML and PDF manuals, as well as the indexes."
  (directory-union (string-append manual "-manual")
                   (map (lambda (proc)
                          (proc source
                                #:date date
                                #:languages languages
                                #:version version
                                #:manual manual))
                        (list html-manual-indexes
                              html-manual pdf-manual))
                   #:copy? #t))

(define (latest-commit+date directory)
  "Return two values: the last commit ID (a hex string) for DIRECTORY, and its
commit date (an integer)."
  (let* ((repository (repository-open directory))
         (head       (repository-head repository))
         (oid        (reference-target head))
         (commit     (commit-lookup repository oid)))
    ;; TODO: Use (git describe) when it's widely available.
    (values (oid->string oid) (commit-time commit))))

\f
(let* ((root (canonicalize-path
              (string-append (current-source-directory) "/..")))
       (commit date (latest-commit+date root)))
  (format (current-error-port)
          "building manual from work tree around commit ~a, ~a~%"
          commit
          (let* ((time (make-time time-utc 0 date))
                 (date (time-utc->date time)))
            (date->string date "~e ~B ~Y")))
  (pdf+html-manual (local-file root "guix" #:recursive? #t
                               #:select? (git-predicate root))
                   #:version (or (getenv "GUIX_MANUAL_VERSION")
                                 (string-take commit 7))
                   #:date date))
Commit	Line	Data
ccadafdc LC	1	;;; GNU Guix --- Functional package management for GNU
	2	;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
	19
	20	;; This file contains machinery to build HTML and PDF copies of the manual
	21	;; that can be readily published on the web site. To do that, run:
	22	;;
	23	;; guix build -f build.scm
	24	;;
	25	;; The result is a directory hierarchy that can be used as the manual/
	26	;; sub-directory of the web site.
	27
	28	(use-modules (guix)
	29	(guix gexp)
	30	(guix git)
	31	(guix git-download)
	32	(git)
	33	(gnu packages base)
	34	(gnu packages gawk)
	35	(gnu packages gettext)
	36	(gnu packages guile)
e591541d	37	(gnu packages iso-codes)
ccadafdc LC	38	(gnu packages texinfo)
	39	(gnu packages tex)
	40	(srfi srfi-19)
	41	(srfi srfi-71))
	42
	43	(define file-append*
	44	(@@ (guix self) file-append*))
	45
	46	(define translated-texi-manuals
	47	(@@ (guix self) translate-texi-manuals))
	48
	49	(define info-manual
	50	(@@ (guix self) info-manual))
	51
	52	(define %languages
	53	'("de" "en" "es" "fr" "ru" "zh_CN"))
	54
	55	(define (texinfo-manual-images source)
	56	"Return a directory containing all the images used by the user manual, taken
	57	from SOURCE, the root of the source tree."
	58	(define graphviz
	59	(module-ref (resolve-interface '(gnu packages graphviz))
	60	'graphviz))
	61
	62	(define images
	63	(file-append* source "doc/images"))
	64
	65	(define build
	66	(with-imported-modules '((guix build utils))
	67	#~(begin
	68	(use-modules (guix build utils)
	69	(srfi srfi-26))
	70
	71	(define (dot->image dot-file format)
	72	(invoke #+(file-append graphviz "/bin/dot")
	73	"-T" format "-Gratio=.9" "-Gnodesep=.005"
	74	"-Granksep=.00005" "-Nfontsize=9"
	75	"-Nheight=.1" "-Nwidth=.1"
	76	"-o" (string-append #$output "/"
	77	(basename dot-file ".dot")
	78	"." format)
	79	dot-file))
	80
	81	;; Build graphs.
	82	(mkdir-p #$output)
	83	(for-each (lambda (dot-file)
	84	(for-each (cut dot->image dot-file <>)
	85	'("png" "pdf")))
	86	(find-files #$images "\\.dot$"))
	87
	88	;; Copy other PNGs.
	89	(for-each (lambda (png-file)
	90	(install-file png-file #$output))
	91	(find-files #$images "\\.png$")))))
	92
	93	(computed-file "texinfo-manual-images" build))
	94
	95	(define* (texinfo-manual-source source #:key
	96	(version "0.0")
	97	(languages %languages)
	98	(date 1))
	99	"Gather all the source files of the Texinfo manuals from SOURCE--.texi file
	100	as well as images, OS examples, and translations."
	101	(define documentation
102	(file-append* source "doc"))
103
104	(define examples
105	(file-append* source "gnu/system/examples"))
106
107	(define build
108	(with-imported-modules '((guix build utils))
109	#~(begin
110	(use-modules (guix build utils)
111	(srfi srfi-19))
112
113	(define (make-version-texi language)
114	;; Create the 'version.texi' file for LANGUAGE.
115	(let ((file (if (string=? language "en")
116	"version.texi"
117	(string-append "version-" language ".texi"))))
118	(call-with-output-file (string-append #$output "/" file)
119	(lambda (port)
120	(let* ((version #$version)
121	(time (make-time time-utc 0 #$date))
122	(date (time-utc->date time)))
123	(format port "
124	@set UPDATED ~a
125	@set UPDATED-MONTH ~a
126	@set EDITION ~a
127	@set VERSION ~a\n"
128	(date->string date "~e ~B ~Y")
129	(date->string date "~B ~Y")
130	version version))))))
131
132	(install-file #$(file-append* documentation "/htmlxref.cnf")
133	#$output)
134
135	(for-each (lambda (texi)
136	(install-file texi #$output))
137	(append (find-files #$documentation "\\.(texi\|scm)$")
138	(find-files #$(translated-texi-manuals source)
139	"\\.texi$")))
140
141	;; Create 'version.texi'.
142	(for-each make-version-texi '#$languages)
143
144	;; Copy configuration templates that the manual includes.
145	(for-each (lambda (template)
146	(copy-file template
147	(string-append
148	#$output "/os-config-"
149	(basename template ".tmpl")
150	".texi")))
151	(find-files #$examples "\\.tmpl$"))
152
153	(symlink #$(texinfo-manual-images source)
154	(string-append #$output "/images")))))
155
156	(computed-file "texinfo-manual-source" build))
157
158	(define %web-site-url
159	;; URL of the web site home page.
160	(or (getenv "GUIX_WEB_SITE_URL")
161	"/software/guix/"))
162
163	(define %makeinfo-html-options
164	;; Options passed to 'makeinfo --html'.
165	'("--css-ref=https://www.gnu.org/software/gnulib/manual.css"))
166
167	(define* (html-manual source #:key (languages %languages)
168	(version "0.0")
169	(manual "guix")
170	(date 1)
171	(options %makeinfo-html-options))
172	"Return the HTML manuals built from SOURCE for all LANGUAGES, with the given
173	makeinfo OPTIONS."
174	(define manual-source
175	(texinfo-manual-source source
176	#:version version
177	#:languages languages
178	#:date date))
179
e3e9c191 LC	180	(define images
	181	(texinfo-manual-images source))
	182
ccadafdc LC	183	(define build
	184	(with-imported-modules '((guix build utils))
	185	#~(begin
	186	(use-modules (guix build utils)
	187	(ice-9 match))
	188
	189	(define (normalize language)
e591541d	190	;; Normalize LANGUAGE. For instance, "zh_CN" becomes "zh-cn".
ccadafdc LC	191	(string-map (match-lambda
	192	(#\_ #\-)
	193	(chr chr))
	194	(string-downcase language)))
	195
	196	;; Install a UTF-8 locale so that 'makeinfo' is at ease.
	197	(setenv "GUIX_LOCPATH"
	198	#+(file-append glibc-utf8-locales "/lib/locale"))
	199	(setenv "LC_ALL" "en_US.utf8")
	200
	201	(setvbuf (current-output-port) 'line)
	202	(setvbuf (current-error-port) 'line)
	203
	204	(for-each (lambda (language)
	205	(let ((opts `("--html"
	206	"-c" ,(string-append "TOP_NODE_UP_URL=/manual/"
	207	language)
	208	#$@options
	209	,(if (string=? language "en")
	210	(string-append #$manual-source "/"
	211	#$manual ".texi")
	212	(string-append #$manual-source "/"
	213	#$manual "." language ".texi")))))
	214	(format #t "building HTML manual for language '~a'...~%"
	215	language)
	216	(mkdir-p (string-append #$output "/"
	217	(normalize language)))
	218	(setenv "LANGUAGE" language)
	219	(apply invoke #$(file-append texinfo "/bin/makeinfo")
	220	"-o" (string-append #$output "/"
	221	(normalize language)
	222	"/html_node")
	223	opts)
	224	(apply invoke #$(file-append texinfo "/bin/makeinfo")
	225	"--no-split"
	226	"-o"
	227	(string-append #$output "/"
	228	(normalize language)
	229	"/" #$manual
	230	(if (string=? language "en")
	231	""
	232	(string-append "." language))
	233	".html")
e3e9c191 LC	234	opts)
	235
	236	;; Make sure images are available.
	237	(symlink #$images
	238	(string-append #$output "/" (normalize language)
	239	"/images"))
	240	(symlink #$images
	241	(string-append #$output "/" (normalize language)
	242	"/html_node/images"))))
ccadafdc LC	243	'#$languages))))
	244
	245	(computed-file (string-append manual "-html-manual") build))
	246
	247	(define* (pdf-manual source #:key (languages %languages)
	248	(version "0.0")
	249	(manual "guix")
	250	(date 1)
	251	(options '()))
	252	"Return the HTML manuals built from SOURCE for all LANGUAGES, with the given
	253	makeinfo OPTIONS."
	254	(define manual-source
	255	(texinfo-manual-source source
	256	#:version version
	257	#:languages languages
	258	#:date date))
	259
	260	;; FIXME: This union works, except for the table of contents of non-English
	261	;; manuals, which contains escape sequences like "^^ca^^fe" instead of
	262	;; accented letters.
	263	;;
	264	;; (define texlive
	265	;; (texlive-union (list texlive-tex-texinfo
	266	;; texlive-generic-epsf
	267	;; texlive-fonts-ec)))
	268
	269	(define build
	270	(with-imported-modules '((guix build utils))
	271	#~(begin
	272	(use-modules (guix build utils)
	273	(srfi srfi-34)
	274	(ice-9 match))
	275
	276	(define (normalize language) ;XXX: deduplicate
	277	;; Normalize LANGUAGE. For instance, "zh_CN" becomes "zh-cn".
	278	(string-map (match-lambda
	279	(#\_ #\-)
	280	(chr chr))
	281	(string-downcase language)))
	282
	283	;; Install a UTF-8 locale so that 'makeinfo' is at ease.
	284	(setenv "GUIX_LOCPATH"
	285	#+(file-append glibc-utf8-locales "/lib/locale"))
	286	(setenv "LC_ALL" "en_US.utf8")
	287	(setenv "PATH"
	288	(string-append #+(file-append texlive "/bin") ":"
	289	#+(file-append texinfo "/bin") ":"
	290
	291	;; Below are command-line tools needed by
	292	;; 'texi2dvi' and friends.
	293	#+(file-append sed "/bin") ":"
	294	#+(file-append grep "/bin") ":"
	295	#+(file-append coreutils "/bin") ":"
	296	#+(file-append gawk "/bin") ":"
	297	#+(file-append tar "/bin") ":"
	298	#+(file-append diffutils "/bin")))
	299
	300	(setvbuf (current-output-port) 'line)
	301	(setvbuf (current-error-port) 'line)
	302
	303	(setenv "HOME" (getcwd)) ;for kpathsea/mktextfm
	304
	305	;; 'SOURCE_DATE_EPOCH' is honored by pdftex.
	306	(setenv "SOURCE_DATE_EPOCH" "1")
307
308	(for-each (lambda (language)
309	(let ((opts `("--pdf"
310	"-I" "."
311	#$@options
312	,(if (string=? language "en")
313	(string-append #$manual-source "/"
314	#$manual ".texi")
315	(string-append #$manual-source "/"
316	#$manual "." language ".texi")))))
317	(format #t "building PDF manual for language '~a'...~%"
318	language)
319	(mkdir-p (string-append #$output "/"
320	(normalize language)))
321	(setenv "LANGUAGE" language)
322
323
324	;; FIXME: Unfortunately building PDFs for non-Latin
325	;; alphabets doesn't work:
326	;; <https://lists.gnu.org/archive/html/help-texinfo/2012-01/msg00014.html>.
327	(guard (c ((invoke-error? c)
328	(format (current-error-port)
329	"~%~%Failed to produce \
330	PDF for language '~a'!~%~%"
331	language)))
332	(apply invoke #$(file-append texinfo "/bin/makeinfo")
333	"--pdf" "-o"
334	(string-append #$output "/"
335	(normalize language)
336	"/" #$manual
337	(if (string=? language "en")
338	""
339	(string-append "."
340	language))
341	".pdf")
342	opts))))
343	'#$languages))))
344
345	(computed-file (string-append manual "-pdf-manual") build))
346
347	(define (guix-manual-text-domain source languages)
348	"Return the PO files for LANGUAGES of the 'guix-manual' text domain taken
349	from SOURCE."
350	(define po-directory
351	(file-append* source "/po/doc"))
352
353	(define build
354	(with-imported-modules '((guix build utils))
355	#~(begin
356	(use-modules (guix build utils))
357
358	(mkdir-p #$output)
359	(for-each (lambda (language)
360	(define directory
361	(string-append #$output "/" language
362	"/LC_MESSAGES"))
363
364	(mkdir-p directory)
365	(invoke #+(file-append gnu-gettext "/bin/msgfmt")
366	"-c" "-o"
367	(string-append directory "/guix-manual.mo")
368	(string-append #$po-directory "/guix-manual."
369	language ".po")))
370	'#$(delete "en" languages)))))
371
372	(computed-file "guix-manual-po" build))
373
374	(define* (html-manual-indexes source
375	#:key (languages %languages)
376	(version "0.0")
377	(manual "guix")
378	(date 1))
379	(define build
e591541d LC	380	(with-extensions (list guile-json-3)
	381	(with-imported-modules '((guix build utils))
	382	#~(begin
	383	(use-modules (guix build utils)
	384	(json)
	385	(ice-9 match)
	386	(ice-9 popen)
	387	(sxml simple)
	388	(srfi srfi-1)
	389	(srfi srfi-19))
	390
	391	(define (normalize language) ;XXX: deduplicate
	392	;; Normalize LANGUAGE. For instance, "zh_CN" becomes "zh-cn".
	393	(string-map (match-lambda
	394	(#\_ #\-)
	395	(chr chr))
	396	(string-downcase language)))
	397
	398	(define-syntax-rule (with-language language exp ...)
	399	(let ((lang (getenv "LANGUAGE")))
	400	(dynamic-wind
	401	(lambda ()
	402	(setenv "LANGUAGE" language)
	403	(setlocale LC_MESSAGES))
	404	(lambda () exp ...)
	405	(lambda ()
	406	(if lang
	407	(setenv "LANGUAGE" lang)
	408	(unsetenv "LANGUAGE"))
	409	(setlocale LC_MESSAGES)))))
	410
	411	;; (put 'with-language 'scheme-indent-function 1)
	412	(define* (translate str language
	413	#:key (domain "guix-manual"))
	414	(define exp
	415	`(begin
	416	(bindtextdomain "guix-manual"
	417	#+(guix-manual-text-domain
	418	source
	419	languages))
	420	(bindtextdomain "iso_639-3" ;language names
	421	#+(file-append iso-codes
	422	"/share/locale"))
	423	(write (gettext ,str ,domain))))
	424
	425	(with-language language
	426	;; Since the 'gettext' function caches msgid translations,
	427	;; regardless of $LANGUAGE, we have to spawn a new process each
	428	;; time we want to translate to a different language. Bah!
	429	(let* ((pipe (open-pipe* OPEN_READ
	430	#+(file-append guile-2.2
	431	"/bin/guile")
	432	"-c" (object->string exp)))
	433	(str (read pipe)))
	434	(close-pipe pipe)
	435	str)))
	436
	437	(define (seconds->string seconds language)
	438	(let* ((time (make-time time-utc 0 seconds))
	439	(date (time-utc->date time)))
	440	(with-language language (date->string date "~e ~B ~Y"))))
	441
	442	(define (guix-url path)
	443	(string-append #$%web-site-url path))
444
445	(define (sxml-index language title body)
446	;; FIXME: Avoid duplicating styling info from guix-artwork.git.
447	`(html (@ (lang ,language))
448	(head
449	(title ,(string-append title " — GNU Guix"))
450	(meta (@ (charset "UTF-8")))
451	(meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
452	;; Menu prefetch.
453	(link (@ (rel "prefetch") (href ,(guix-url "menu/index.html"))))
454	;; Base CSS.
455	(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/elements.css"))))
456	(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/common.css"))))
457	(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/messages.css"))))
458	(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/navbar.css"))))
459	(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/breadcrumbs.css"))))
460	(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/buttons.css"))))
461	(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/footer.css"))))
462
463	(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/page.css"))))
464	(link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/post.css")))))
465	(body
466	(header (@ (class "navbar"))
467	(h1 (a (@ (class "branding")
468	(href #$%web-site-url)))
469	(span (@ (class "a11y-offset"))
470	"Guix"))
471	(nav (@ (class "menu"))))
472	(nav (@ (class "breadcrumbs"))
473	(a (@ (class "crumb")
474	(href #$%web-site-url))
475	"Home"))
476	,body
477	(footer))))
478
479	(define (language-index language)
480	(define title
481	(translate "GNU Guix Reference Manual" language))
482
483	(sxml-index
484	language title
485	`(main
486	(article
487	(@ (class "page centered-block limit-width"))
488	(h2 ,title)
489	(p (@ (class "post-metadata centered-text"))
490	#$version " — "
491	,(seconds->string #$date language))
492
493	(div
494	(ul
495	(li (a (@ (href "html_node"))
496	"HTML, with one page per node"))
497	(li (a (@ (href
498	,(string-append
499	#$manual
500	(if (string=? language
501	"en")
502	""
503	(string-append "."
504	language))
505	".html")))
506	"HTML, entirely on one page"))
507	,@(if (member language '("ru" "zh_CN"))
508	'()
509	`((li (a (@ (href ,(string-append
510	#$manual
511	(if (string=? language "en")
512	""
513	(string-append "."
514	language))
515	".pdf"))))
516	"PDF")))))))))
517
518	(define %iso639-languages
519	(vector->list
520	(assoc-ref (call-with-input-file
521	#+(file-append iso-codes
522	"/share/iso-codes/json/iso_639-3.json")
523	json->scm)
524	"639-3")))
525
526	(define (language-code->name code)
527	"Return the full name of a language from its ISO-639-3 code."
528	(let ((code (match (string-index code #\_)
529	(#f code)
530	(index (string-take code index)))))
531	(any (lambda (language)
532	(and (string=? (or (assoc-ref language "alpha_2")
533	(assoc-ref language "alpha_3"))
534	code)
535	(assoc-ref language "name")))
536	%iso639-languages)))
537
538	(define (top-level-index languages)
539	(define title
540	"GNU Guix Reference Manual")
541	(sxml-index
542	"en" title
543	`(main
544	(article
545	(@ (class "page centered-block limit-width"))
546	(h2 ,title)
547	(div
548	"The GNU Guix Reference Manual is available in the following
549	languages:\n"
550	(ul
551	,@(map (lambda (language)
552	`(li (a (@ (href ,(normalize language)))
553	,(translate
554	(language-code->name language)
555	language
556	#:domain "iso_639-3"))))
557	languages)))))))
558
559	(define (write-html file sxml)
560	(call-with-output-file file
561	(lambda (port)
562	(display "<!DOCTYPE html>\n" port)
563	(sxml->xml sxml port))))
564
565	(setenv "GUIX_LOCPATH"
566	#+(file-append glibc-utf8-locales "/lib/locale"))
567	(setenv "LC_ALL" "en_US.utf8")
568	(setlocale LC_ALL "en_US.utf8")
569
570	(for-each (lambda (language)
571	(define directory
572	(string-append #$output "/"
573	(normalize language)))
574
575	(mkdir-p directory)
576	(write-html (string-append directory "/index.html")
577	(language-index language)))
578	'#$languages)
579
580	(write-html (string-append #$output "/index.html")
581	(top-level-index '#$languages))))))
ccadafdc LC	582
	583	(computed-file "html-indexes" build))
	584
	585	(define* (pdf+html-manual source
	586	#:key (languages %languages)
	587	(version "0.0")
	588	(date (time-second (current-time time-utc)))
	589	(manual "guix"))
	590	"Return the union of the HTML and PDF manuals, as well as the indexes."
	591	(directory-union (string-append manual "-manual")
	592	(map (lambda (proc)
	593	(proc source
	594	#:date date
	595	#:languages languages
	596	#:version version
	597	#:manual manual))
	598	(list html-manual-indexes
	599	html-manual pdf-manual))
	600	#:copy? #t))
	601
	602	(define (latest-commit+date directory)
	603	"Return two values: the last commit ID (a hex string) for DIRECTORY, and its
	604	commit date (an integer)."
	605	(let* ((repository (repository-open directory))
	606	(head (repository-head repository))
	607	(oid (reference-target head))
	608	(commit (commit-lookup repository oid)))
	609	;; TODO: Use (git describe) when it's widely available.
	610	(values (oid->string oid) (commit-time commit))))
	611
	612	\f
	613	(let* ((root (canonicalize-path
	614	(string-append (current-source-directory) "/..")))
	615	(commit date (latest-commit+date root)))
	616	(format (current-error-port)
	617	"building manual from work tree around commit ~a, ~a~%"
	618	commit
	619	(let* ((time (make-time time-utc 0 date))
	620	(date (time-utc->date time)))
	621	(date->string date "~e ~B ~Y")))
	622	(pdf+html-manual (local-file root "guix" #:recursive? #t
	623	#:select? (git-predicate root))
	624	#:version (or (getenv "GUIX_MANUAL_VERSION")
	625	(string-take commit 7))
	626	#:date date))