doc/build.scm

   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              (guix utils)
  33              (git)
  34              (gnu packages base)
  35              (gnu packages gawk)
  36              (gnu packages gettext)
  37              (gnu packages guile)
  38              (gnu packages guile-xyz)
  39              (gnu packages iso-codes)
  40              (gnu packages texinfo)
  41              (gnu packages tex)
  42              (srfi srfi-19)
  43              (srfi srfi-71))
  44
  45 (define file-append*
  46   (@@ (guix self) file-append*))
  47
  48 (define translated-texi-manuals
  49   (@@ (guix self) translate-texi-manuals))
  50
  51 (define info-manual
  52   (@@ (guix self) info-manual))
  53
  54 (define %languages
  55   '("de" "en" "es" "fr" "ru" "zh_CN"))
  56
  57 (define (texinfo-manual-images source)
  58   "Return a directory containing all the images used by the user manual, taken
  59 from SOURCE, the root of the source tree."
  60   (define graphviz
  61     (module-ref (resolve-interface '(gnu packages graphviz))
  62                 'graphviz))
  63
  64   (define images
  65     (file-append* source "doc/images"))
  66
  67   (define build
  68     (with-imported-modules '((guix build utils))
  69       #~(begin
  70           (use-modules (guix build utils)
  71                        (srfi srfi-26))
  72
  73           (define (dot->image dot-file format)
  74             (invoke #+(file-append graphviz "/bin/dot")
  75                     "-T" format "-Gratio=.9" "-Gnodesep=.005"
  76                     "-Granksep=.00005" "-Nfontsize=9"
  77                     "-Nheight=.1" "-Nwidth=.1"
  78                     "-o" (string-append #$output "/"
  79                                         (basename dot-file ".dot")
  80                                         "." format)
  81                     dot-file))
  82
  83           ;; Build graphs.
  84           (mkdir-p #$output)
  85           (for-each (lambda (dot-file)
  86                       (for-each (cut dot->image dot-file <>)
  87                                 '("png" "pdf")))
  88                     (find-files #$images "\\.dot$"))
  89
  90           ;; Copy other PNGs.
  91           (for-each (lambda (png-file)
  92                       (install-file png-file #$output))
  93                     (find-files #$images "\\.png$")))))
  94
  95   (computed-file "texinfo-manual-images" build))
  96
  97 (define* (texinfo-manual-source source #:key
  98                                 (version "0.0")
  99                                 (languages %languages)
 100                                 (date 1))
 101   "Gather all the source files of the Texinfo manuals from SOURCE--.texi file
 102 as well as images, OS examples, and translations."
 103   (define documentation
 104     (file-append* source "doc"))
 105
 106   (define examples
 107     (file-append* source "gnu/system/examples"))
 108
 109   (define build
 110     (with-imported-modules '((guix build utils))
 111       #~(begin
 112           (use-modules (guix build utils)
 113                        (srfi srfi-19))
 114
 115           (define (make-version-texi language)
 116             ;; Create the 'version.texi' file for LANGUAGE.
 117             (let ((file (if (string=? language "en")
 118                             "version.texi"
 119                             (string-append "version-" language ".texi"))))
 120               (call-with-output-file (string-append #$output "/" file)
 121                 (lambda (port)
 122                   (let* ((version #$version)
 123                          (time    (make-time time-utc 0 #$date))
 124                          (date    (time-utc->date time)))
 125                     (format port "
 126 @set UPDATED ~a
 127 @set UPDATED-MONTH ~a
 128 @set EDITION ~a
 129 @set VERSION ~a\n"
 130                             (date->string date "~e ~B ~Y")
 131                             (date->string date "~B ~Y")
 132                             version version))))))
 133
 134           (install-file #$(file-append* documentation "/htmlxref.cnf")
 135                         #$output)
 136
 137           (for-each (lambda (texi)
 138                       (install-file texi #$output))
 139                     (append (find-files #$documentation "\\.(texi|scm)$")
 140                             (find-files #$(translated-texi-manuals source)
 141                                         "\\.texi$")))
 142
 143           ;; Create 'version.texi'.
 144           (for-each make-version-texi '#$languages)
 145
 146           ;; Copy configuration templates that the manual includes.
 147           (for-each (lambda (template)
 148                       (copy-file template
 149                                  (string-append
 150                                   #$output "/os-config-"
 151                                   (basename template ".tmpl")
 152                                   ".texi")))
 153                     (find-files #$examples "\\.tmpl$"))
 154
 155           (symlink #$(texinfo-manual-images source)
 156                    (string-append #$output "/images")))))
 157
 158   (computed-file "texinfo-manual-source" build))
 159
 160 (define %web-site-url
 161   ;; URL of the web site home page.
 162   (or (getenv "GUIX_WEB_SITE_URL")
 163       "/software/guix/"))
 164
 165 (define %makeinfo-html-options
 166   ;; Options passed to 'makeinfo --html'.
 167   '("--css-ref=https://www.gnu.org/software/gnulib/manual.css"))
 168
 169 (define guile-lib/htmlprag-fixed
 170   ;; Guile-Lib with a hotfix for (htmlprag).
 171   (package
 172     (inherit guile-lib)
 173     (source (origin
 174               (inherit (package-source guile-lib))
 175               (modules '(( guix build utils)))
 176               (snippet
 177                '(begin
 178                   ;; When parsing
 179                   ;; "<body><blockquote><p>foo</p>\n</blockquote></body>",
 180                   ;; 'html->shtml' would mistakenly close 'blockquote' right
 181                   ;; before <p>.  This patch removes 'p' from the
 182                   ;; 'parent-constraints' alist to fix that.
 183                   (substitute* "src/htmlprag.scm"
 184                     (("^[[:blank:]]*\\(p[[:blank:]]+\\. \\(body td th\\)\\).*")
 185                      ""))
 186                   #t))))
 187     (arguments
 188      (substitute-keyword-arguments (package-arguments guile-lib)
 189        ((#:phases phases '%standard-phases)
 190         `(modify-phases ,phases
 191           (add-before 'check 'skip-known-failure
 192             (lambda _
 193               ;; XXX: The above change causes one test failure among
 194               ;; the htmlprag tests.
 195               (setenv "XFAIL_TESTS" "htmlprag.scm")
 196               #t))))))))
 197
 198 (define* (syntax-highlighted-html input
 199                                   #:key
 200                                   (name "highlighted-syntax")
 201                                   (syntax-css-url
 202                                    "/static/base/css/code.css"))
 203   "Return a derivation called NAME that processes all the HTML files in INPUT
 204 to (1) add them a link to SYNTAX-CSS-URL, and (2) highlight the syntax of all
 205 its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
 206   (define build
 207     (with-extensions (list guile-lib/htmlprag-fixed guile-syntax-highlight)
 208       (with-imported-modules '((guix build utils))
 209         #~(begin
 210             (use-modules (htmlprag)
 211                          (syntax-highlight)
 212                          (syntax-highlight scheme)
 213                          (syntax-highlight lexers)
 214                          (guix build utils)
 215                          (ice-9 match)
 216                          (ice-9 threads))
 217
 218             (define entity->string
 219               (match-lambda
 220                 ("rArr"   "⇒")
 221                 ("hellip" "…")
 222                 ("rsquo"  "’")
 223                 (e (pk 'unknown-entity e) (primitive-exit 2))))
 224
 225             (define (concatenate-snippets pieces)
 226               ;; Concatenate PIECES, which contains strings and entities,
 227               ;; replacing entities with their corresponding string.
 228               (let loop ((pieces pieces)
 229                          (strings '()))
 230                 (match pieces
 231                   (()
 232                    (string-concatenate-reverse strings))
 233                   (((? string? str) . rest)
 234                    (loop rest (cons str strings)))
 235                   ((('*ENTITY* "additional" entity) . rest)
 236                    (loop rest (cons (entity->string entity) strings)))
 237                   ((('span _ lst ...) . rest)     ;for <span class="roman">
 238                    (loop (append lst rest) strings))
 239                   (something
 240                    (pk 'unsupported-code-snippet something)
 241                    (primitive-exit 1)))))
 242
 243             (define (syntax-highlight sxml)
 244               ;; Recurse over SXML and syntax-highlight code snippets.
 245               (match sxml
 246                 (('*TOP* decl body ...)
 247                  `(*TOP* ,decl ,@(map syntax-highlight body)))
 248                 (('head things ...)
 249                  `(head ,@things
 250                         (link (@ (rel "stylesheet")
 251                                  (type "text/css")
 252                                  (href #$syntax-css-url)))))
 253                 (('pre ('@ ('class "lisp")) code-snippet ...)
 254                  `(pre (@ (class "lisp"))
 255                        ,(highlights->sxml
 256                          (highlight lex-scheme
 257                                     (concatenate-snippets code-snippet)))))
 258                 ((tag ('@ attributes ...) body ...)
 259                  `(,tag (@ ,@attributes) ,@(map syntax-highlight body)))
 260                 ((tag body ...)
 261                  `(,tag ,@(map syntax-highlight body)))
 262                 ((? string? str)
 263                  str)))
 264
 265             (define (process-html file)
 266               ;; Parse FILE and perform syntax highlighting for its Scheme
 267               ;; snippets.  Install the result to #$output.
 268               (format (current-error-port) "processing ~a...~%" file)
 269               (let* ((shtml        (call-with-input-file file html->shtml))
 270                      (highlighted  (syntax-highlight shtml))
 271                      (base         (string-drop file (string-length #$input)))
 272                      (target       (string-append #$output base)))
 273                 (mkdir-p (dirname target))
 274                 (call-with-output-file target
 275                   (lambda (port)
 276                     (write-shtml-as-html highlighted port)))))
 277
 278             (define (copy-as-is file)
 279               ;; Copy FILE as is to #$output.
 280               (let* ((base   (string-drop file (string-length #$input)))
 281                      (target (string-append #$output base)))
 282                 (mkdir-p (dirname target))
 283                 (catch 'system-error
 284                   (lambda ()
 285                     (if (eq? 'symlink (stat:type (lstat file)))
 286                         (symlink (readlink file) target)
 287                         (link file target)))
 288                   (lambda args
 289                     (let ((errno (system-error-errno args)))
 290                       (pk 'error-link file target (strerror errno))
 291                       (primitive-exit 3))))))
 292
 293             ;; Install a UTF-8 locale so we can process UTF-8 files.
 294             (setenv "GUIX_LOCPATH"
 295                     #+(file-append glibc-utf8-locales "/lib/locale"))
 296             (setlocale LC_ALL "en_US.utf8")
 297
 298             (n-par-for-each (parallel-job-count)
 299                             (lambda (file)
 300                               (if (string-suffix? ".html" file)
 301                                   (process-html file)
 302                                   (copy-as-is file)))
 303                             (find-files #$input))))))
 304
 305   (computed-file name build))
 306
 307 (define* (html-manual source #:key (languages %languages)
 308                       (version "0.0")
 309                       (manual "guix")
 310                       (date 1)
 311                       (options %makeinfo-html-options))
 312   "Return the HTML manuals built from SOURCE for all LANGUAGES, with the given
 313 makeinfo OPTIONS."
 314   (define manual-source
 315     (texinfo-manual-source source
 316                            #:version version
 317                            #:languages languages
 318                            #:date date))
 319
 320   (define images
 321     (texinfo-manual-images source))
 322
 323   (define build
 324     (with-imported-modules '((guix build utils))
 325       #~(begin
 326           (use-modules (guix build utils)
 327                        (ice-9 match))
 328
 329           (define (normalize language)
 330             ;; Normalize LANGUAGE.  For instance, "zh_CN" becomes "zh-cn".
 331             (string-map (match-lambda
 332                           (#\_ #\-)
 333                           (chr chr))
 334                         (string-downcase language)))
 335
 336           ;; Install a UTF-8 locale so that 'makeinfo' is at ease.
 337           (setenv "GUIX_LOCPATH"
 338                   #+(file-append glibc-utf8-locales "/lib/locale"))
 339           (setenv "LC_ALL" "en_US.utf8")
 340
 341           (setvbuf (current-output-port) 'line)
 342           (setvbuf (current-error-port) 'line)
 343
 344           (for-each (lambda (language)
 345                       (let ((opts `("--html"
 346                                     "-c" ,(string-append "TOP_NODE_UP_URL=/manual/"
 347                                                          language)
 348                                     #$@options
 349                                     ,(if (string=? language "en")
 350                                          (string-append #$manual-source "/"
 351                                                         #$manual ".texi")
 352                                          (string-append #$manual-source "/"
 353                                                         #$manual "." language ".texi")))))
 354                         (format #t "building HTML manual for language '~a'...~%"
 355                                 language)
 356                         (mkdir-p (string-append #$output "/"
 357                                                 (normalize language)))
 358                         (setenv "LANGUAGE" language)
 359                         (apply invoke #$(file-append texinfo "/bin/makeinfo")
 360                                "-o" (string-append #$output "/"
 361                                                    (normalize language)
 362                                                    "/html_node")
 363                                opts)
 364                         (apply invoke #$(file-append texinfo "/bin/makeinfo")
 365                                "--no-split"
 366                                "-o"
 367                                (string-append #$output "/"
 368                                               (normalize language)
 369                                               "/" #$manual
 370                                               (if (string=? language "en")
 371                                                   ""
 372                                                   (string-append "." language))
 373                                               ".html")
 374                                opts)
 375
 376                         ;; Make sure images are available.
 377                         (symlink #$images
 378                                  (string-append #$output "/" (normalize language)
 379                                                 "/images"))
 380                         (symlink #$images
 381                                  (string-append #$output "/" (normalize language)
 382                                                 "/html_node/images"))))
 383                     '#$languages))))
 384
 385   (let* ((name   (string-append manual "-html-manual"))
 386          (manual (computed-file name build)))
 387     (syntax-highlighted-html manual
 388                              #:name (string-append name "-highlighted"))))
 389
 390 (define* (pdf-manual source #:key (languages %languages)
 391                      (version "0.0")
 392                      (manual "guix")
 393                      (date 1)
 394                      (options '()))
 395   "Return the HTML manuals built from SOURCE for all LANGUAGES, with the given
 396 makeinfo OPTIONS."
 397   (define manual-source
 398     (texinfo-manual-source source
 399                            #:version version
 400                            #:languages languages
 401                            #:date date))
 402
 403   ;; FIXME: This union works, except for the table of contents of non-English
 404   ;; manuals, which contains escape sequences like "^^ca^^fe" instead of
 405   ;; accented letters.
 406   ;;
 407   ;; (define texlive
 408   ;;   (texlive-union (list texlive-tex-texinfo
 409   ;;                        texlive-generic-epsf
 410   ;;                        texlive-fonts-ec)))
 411
 412   (define build
 413     (with-imported-modules '((guix build utils))
 414       #~(begin
 415           (use-modules (guix build utils)
 416                        (srfi srfi-34)
 417                        (ice-9 match))
 418
 419           (define (normalize language)            ;XXX: deduplicate
 420             ;; Normalize LANGUAGE.  For instance, "zh_CN" becomes "zh-cn".
 421             (string-map (match-lambda
 422                           (#\_ #\-)
 423                           (chr chr))
 424                         (string-downcase language)))
 425
 426           ;; Install a UTF-8 locale so that 'makeinfo' is at ease.
 427           (setenv "GUIX_LOCPATH"
 428                   #+(file-append glibc-utf8-locales "/lib/locale"))
 429           (setenv "LC_ALL" "en_US.utf8")
 430           (setenv "PATH"
 431                   (string-append #+(file-append texlive "/bin") ":"
 432                                  #+(file-append texinfo "/bin") ":"
 433
 434                                  ;; Below are command-line tools needed by
 435                                  ;; 'texi2dvi' and friends.
 436                                  #+(file-append sed "/bin") ":"
 437                                  #+(file-append grep "/bin") ":"
 438                                  #+(file-append coreutils "/bin") ":"
 439                                  #+(file-append gawk "/bin") ":"
 440                                  #+(file-append tar "/bin") ":"
 441                                  #+(file-append diffutils "/bin")))
 442
 443           (setvbuf (current-output-port) 'line)
 444           (setvbuf (current-error-port) 'line)
 445
 446           (setenv "HOME" (getcwd))                ;for kpathsea/mktextfm
 447
 448           ;; 'SOURCE_DATE_EPOCH' is honored by pdftex.
 449           (setenv "SOURCE_DATE_EPOCH" "1")
 450
 451           (for-each (lambda (language)
 452                       (let ((opts `("--pdf"
 453                                     "-I" "."
 454                                     #$@options
 455                                     ,(if (string=? language "en")
 456                                          (string-append #$manual-source "/"
 457                                                         #$manual ".texi")
 458                                          (string-append #$manual-source "/"
 459                                                         #$manual "." language ".texi")))))
 460                         (format #t "building PDF manual for language '~a'...~%"
 461                                 language)
 462                         (mkdir-p (string-append #$output "/"
 463                                                 (normalize language)))
 464                         (setenv "LANGUAGE" language)
 465
 466
 467                         ;; FIXME: Unfortunately building PDFs for non-Latin
 468                         ;; alphabets doesn't work:
 469                         ;; <https://lists.gnu.org/archive/html/help-texinfo/2012-01/msg00014.html>.
 470                         (guard (c ((invoke-error? c)
 471                                    (format (current-error-port)
 472                                            "~%~%Failed to produce \
 473 PDF for language '~a'!~%~%"
 474                                            language)))
 475                          (apply invoke #$(file-append texinfo "/bin/makeinfo")
 476                                 "--pdf" "-o"
 477                                 (string-append #$output "/"
 478                                                (normalize language)
 479                                                "/" #$manual
 480                                                (if (string=? language "en")
 481                                                    ""
 482                                                    (string-append "."
 483                                                                   language))
 484                                                ".pdf")
 485                                 opts))))
 486                     '#$languages))))
 487
 488   (computed-file (string-append manual "-pdf-manual") build))
 489
 490 (define (guix-manual-text-domain source languages)
 491   "Return the PO files for LANGUAGES of the 'guix-manual' text domain taken
 492 from SOURCE."
 493   (define po-directory
 494     (file-append* source "/po/doc"))
 495
 496   (define build
 497     (with-imported-modules '((guix build utils))
 498       #~(begin
 499           (use-modules (guix build utils))
 500
 501           (mkdir-p #$output)
 502           (for-each (lambda (language)
 503                       (define directory
 504                         (string-append #$output "/" language
 505                                        "/LC_MESSAGES"))
 506
 507                       (mkdir-p directory)
 508                       (invoke #+(file-append gnu-gettext "/bin/msgfmt")
 509                               "-c" "-o"
 510                               (string-append directory "/guix-manual.mo")
 511                               (string-append #$po-directory "/guix-manual."
 512                                              language ".po")))
 513                     '#$(delete "en" languages)))))
 514
 515   (computed-file "guix-manual-po" build))
 516
 517 (define* (html-manual-indexes source
 518                               #:key (languages %languages)
 519                               (version "0.0")
 520                               (manual "guix")
 521                               (date 1))
 522   (define build
 523     (with-extensions (list guile-json-3)
 524       (with-imported-modules '((guix build utils))
 525         #~(begin
 526             (use-modules (guix build utils)
 527                          (json)
 528                          (ice-9 match)
 529                          (ice-9 popen)
 530                          (sxml simple)
 531                          (srfi srfi-1)
 532                          (srfi srfi-19))
 533
 534             (define (normalize language)          ;XXX: deduplicate
 535               ;; Normalize LANGUAGE.  For instance, "zh_CN" becomes "zh-cn".
 536               (string-map (match-lambda
 537                             (#\_ #\-)
 538                             (chr chr))
 539                           (string-downcase language)))
 540
 541             (define-syntax-rule (with-language language exp ...)
 542               (let ((lang (getenv "LANGUAGE")))
 543                 (dynamic-wind
 544                   (lambda ()
 545                     (setenv "LANGUAGE" language)
 546                     (setlocale LC_MESSAGES))
 547                   (lambda () exp ...)
 548                   (lambda ()
 549                     (if lang
 550                         (setenv "LANGUAGE" lang)
 551                         (unsetenv "LANGUAGE"))
 552                     (setlocale LC_MESSAGES)))))
 553
 554             ;; (put 'with-language 'scheme-indent-function 1)
 555             (define* (translate str language
 556                                 #:key (domain "guix-manual"))
 557               (define exp
 558                 `(begin
 559                    (bindtextdomain "guix-manual"
 560                                    #+(guix-manual-text-domain
 561                                       source
 562                                       languages))
 563                    (bindtextdomain "iso_639-3"    ;language names
 564                                    #+(file-append iso-codes
 565                                                   "/share/locale"))
 566                    (write (gettext ,str ,domain))))
 567
 568               (with-language language
 569                 ;; Since the 'gettext' function caches msgid translations,
 570                 ;; regardless of $LANGUAGE, we have to spawn a new process each
 571                 ;; time we want to translate to a different language.  Bah!
 572                 (let* ((pipe (open-pipe* OPEN_READ
 573                                          #+(file-append guile-2.2
 574                                                         "/bin/guile")
 575                                          "-c" (object->string exp)))
 576                        (str  (read pipe)))
 577                   (close-pipe pipe)
 578                   str)))
 579
 580             (define (seconds->string seconds language)
 581               (let* ((time (make-time time-utc 0 seconds))
 582                      (date (time-utc->date time)))
 583                 (with-language language (date->string date "~e ~B ~Y"))))
 584
 585             (define (guix-url path)
 586               (string-append #$%web-site-url path))
 587
 588             (define (sxml-index language title body)
 589               ;; FIXME: Avoid duplicating styling info from guix-artwork.git.
 590               `(html (@ (lang ,language))
 591                      (head
 592                       (title ,(string-append title " — GNU Guix"))
 593                       (meta (@ (charset "UTF-8")))
 594                       (meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
 595                       ;; Menu prefetch.
 596                       (link (@ (rel "prefetch") (href ,(guix-url "menu/index.html"))))
 597                       ;; Base CSS.
 598                       (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/elements.css"))))
 599                       (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/common.css"))))
 600                       (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/messages.css"))))
 601                       (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/navbar.css"))))
 602                       (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/breadcrumbs.css"))))
 603                       (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/buttons.css"))))
 604                       (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/footer.css"))))
 605
 606                       (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/page.css"))))
 607                       (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/post.css")))))
 608                      (body
 609                       (header (@ (class "navbar"))
 610                               (h1 (a (@ (class "branding")
 611                                         (href #$%web-site-url)))
 612                                   (span (@ (class "a11y-offset"))
 613                                         "Guix"))
 614                               (nav (@ (class "menu"))))
 615                       (nav (@ (class "breadcrumbs"))
 616                            (a (@ (class "crumb")
 617                                  (href #$%web-site-url))
 618                               "Home"))
 619                       ,body
 620                       (footer))))
 621
 622             (define (language-index language)
 623               (define title
 624                 (translate "GNU Guix Reference Manual" language))
 625
 626               (sxml-index
 627                language title
 628                `(main
 629                  (article
 630                   (@ (class "page centered-block limit-width"))
 631                   (h2 ,title)
 632                   (p (@ (class "post-metadata centered-text"))
 633                      #$version " — "
 634                      ,(seconds->string #$date language))
 635
 636                   (div
 637                    (ul
 638                     (li (a (@ (href "html_node"))
 639                            "HTML, with one page per node"))
 640                     (li (a (@ (href
 641                                ,(string-append
 642                                  #$manual
 643                                  (if (string=? language
 644                                                "en")
 645                                      ""
 646                                      (string-append "."
 647                                                     language))
 648                                  ".html")))
 649                            "HTML, entirely on one page"))
 650                     ,@(if (member language '("ru" "zh_CN"))
 651                           '()
 652                           `((li (a (@ (href ,(string-append
 653                                               #$manual
 654                                               (if (string=? language "en")
 655                                                   ""
 656                                                   (string-append "."
 657                                                                  language))
 658                                               ".pdf"))))
 659                                 "PDF")))))))))
 660
 661             (define %iso639-languages
 662               (vector->list
 663                (assoc-ref (call-with-input-file
 664                               #+(file-append iso-codes
 665                                              "/share/iso-codes/json/iso_639-3.json")
 666                             json->scm)
 667                           "639-3")))
 668
 669             (define (language-code->name code)
 670               "Return the full name of a language from its ISO-639-3 code."
 671               (let ((code (match (string-index code #\_)
 672                             (#f    code)
 673                             (index (string-take code index)))))
 674                (any (lambda (language)
 675                       (and (string=? (or (assoc-ref language "alpha_2")
 676                                          (assoc-ref language "alpha_3"))
 677                                      code)
 678                            (assoc-ref language "name")))
 679                     %iso639-languages)))
 680
 681             (define (top-level-index languages)
 682               (define title
 683                 "GNU Guix Reference Manual")
 684               (sxml-index
 685                "en" title
 686                `(main
 687                  (article
 688                   (@ (class "page centered-block limit-width"))
 689                   (h2 ,title)
 690                   (div
 691                    "The GNU Guix Reference Manual is available in the following
 692 languages:\n"
 693                    (ul
 694                     ,@(map (lambda (language)
 695                              `(li (a (@ (href ,(normalize language)))
 696                                      ,(translate
 697                                        (language-code->name language)
 698                                        language
 699                                        #:domain "iso_639-3"))))
 700                            languages)))))))
 701
 702             (define (write-html file sxml)
 703               (call-with-output-file file
 704                 (lambda (port)
 705                   (display "<!DOCTYPE html>\n" port)
 706                   (sxml->xml sxml port))))
 707
 708             (setenv "GUIX_LOCPATH"
 709                     #+(file-append glibc-utf8-locales "/lib/locale"))
 710             (setenv "LC_ALL" "en_US.utf8")
 711             (setlocale LC_ALL "en_US.utf8")
 712
 713             (for-each (lambda (language)
 714                         (define directory
 715                           (string-append #$output "/"
 716                                          (normalize language)))
 717
 718                         (mkdir-p directory)
 719                         (write-html (string-append directory "/index.html")
 720                                     (language-index language)))
 721                       '#$languages)
 722
 723             (write-html (string-append #$output "/index.html")
 724                         (top-level-index '#$languages))))))
 725
 726   (computed-file "html-indexes" build))
 727
 728 (define* (pdf+html-manual source
 729                           #:key (languages %languages)
 730                           (version "0.0")
 731                           (date (time-second (current-time time-utc)))
 732                           (manual "guix"))
 733   "Return the union of the HTML and PDF manuals, as well as the indexes."
 734   (directory-union (string-append manual "-manual")
 735                    (map (lambda (proc)
 736                           (proc source
 737                                 #:date date
 738                                 #:languages languages
 739                                 #:version version
 740                                 #:manual manual))
 741                         (list html-manual-indexes
 742                               html-manual pdf-manual))
 743                    #:copy? #t))
 744
 745 (define (latest-commit+date directory)
 746   "Return two values: the last commit ID (a hex string) for DIRECTORY, and its
 747 commit date (an integer)."
 748   (let* ((repository (repository-open directory))
 749          (head       (repository-head repository))
 750          (oid        (reference-target head))
 751          (commit     (commit-lookup repository oid)))
 752     ;; TODO: Use (git describe) when it's widely available.
 753     (values (oid->string oid) (commit-time commit))))
 754
 755 \f
 756 (let* ((root (canonicalize-path
 757               (string-append (current-source-directory) "/..")))
 758        (commit date (latest-commit+date root)))
 759   (format (current-error-port)
 760           "building manual from work tree around commit ~a, ~a~%"
 761           commit
 762           (let* ((time (make-time time-utc 0 date))
 763                  (date (time-utc->date time)))
 764             (date->string date "~e ~B ~Y")))
 765   (pdf+html-manual (local-file root "guix" #:recursive? #t
 766                                #:select? (git-predicate root))
 767                    #:version (or (getenv "GUIX_MANUAL_VERSION")
 768                                  (string-take commit 7))
 769                    #:date date))