doc/build.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2019-2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2020 Björn Höfling <bjoern.hoefling@bjoernhoefling.de>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20
  21 ;; This file contains machinery to build HTML and PDF copies of the manual
  22 ;; that can be readily published on the web site.  To do that, run:
  23 ;;
  24 ;;  guix build -f build.scm
  25 ;;
  26 ;; The result is a directory hierarchy that can be used as the manual/
  27 ;; sub-directory of the web site.
  28
  29 (use-modules (guix)
  30              (guix gexp)
  31              (guix git)
  32              (guix git-download)
  33              (guix utils)
  34              (git)
  35              (gnu packages base)
  36              (gnu packages compression)
  37              (gnu packages gawk)
  38              (gnu packages gettext)
  39              (gnu packages guile)
  40              (gnu packages guile-xyz)
  41              (gnu packages iso-codes)
  42              (gnu packages texinfo)
  43              (gnu packages tex)
  44              (ice-9 match)
  45              (srfi srfi-1)
  46              (srfi srfi-19)
  47              (srfi srfi-26)
  48              (srfi srfi-71))
  49
  50 (define file-append*
  51   (@@ (guix self) file-append*))
  52
  53 (define translated-texi-manuals
  54   (@@ (guix self) translate-texi-manuals))
  55
  56 (define info-manual
  57   (@@ (guix self) info-manual))
  58
  59 (define %manual
  60   ;; The manual to build--i.e., the base name of a .texi file, such as "guix"
  61   ;; or "guix-cookbook".
  62   (or (getenv "GUIX_MANUAL")
  63       "guix"))
  64
  65 (define %manual-languages
  66   ;; Available translations for the 'guix-manual' text domain.
  67   '("de" "en" "es" "fr" "ru" "zh_CN"))
  68
  69 (define %cookbook-languages
  70   ;; Available translations for the 'guix-cookbook' text domain.
  71   '("de" "en" "fr" "sk"))
  72
  73 (define %languages
  74   ;; Available translations for the document being built.
  75   (if (string=? %manual "guix-cookbook")
  76       %cookbook-languages
  77       %manual-languages))
  78
  79 (define (texinfo-manual-images source)
  80   "Return a directory containing all the images used by the user manual, taken
  81 from SOURCE, the root of the source tree."
  82   (define graphviz
  83     (module-ref (resolve-interface '(gnu packages graphviz))
  84                 'graphviz))
  85
  86   (define images
  87     (file-append* source "doc/images"))
  88
  89   (define build
  90     (with-imported-modules '((guix build utils))
  91       #~(begin
  92           (use-modules (guix build utils)
  93                        (srfi srfi-26))
  94
  95           (define (dot->image dot-file format)
  96             (invoke #+(file-append graphviz "/bin/dot")
  97                     "-T" format "-Gratio=.9" "-Gnodesep=.005"
  98                     "-Granksep=.00005" "-Nfontsize=9"
  99                     "-Nheight=.1" "-Nwidth=.1"
 100                     "-o" (string-append #$output "/"
 101                                         (basename dot-file ".dot")
 102                                         "." format)
 103                     dot-file))
 104
 105           ;; Build graphs.
 106           (mkdir-p #$output)
 107           (for-each (lambda (dot-file)
 108                       (for-each (cut dot->image dot-file <>)
 109                                 '("png" "pdf")))
 110                     (find-files #$images "\\.dot$"))
 111
 112           ;; Copy other PNGs.
 113           (for-each (lambda (png-file)
 114                       (install-file png-file #$output))
 115                     (find-files #$images "\\.png$")))))
 116
 117   (computed-file "texinfo-manual-images" build))
 118
 119 (define* (texinfo-manual-source source #:key
 120                                 (version "0.0")
 121                                 (languages %languages)
 122                                 (date 1))
 123   "Gather all the source files of the Texinfo manuals from SOURCE--.texi file
 124 as well as images, OS examples, and translations."
 125   (define documentation
 126     (file-append* source "doc"))
 127
 128   (define examples
 129     (file-append* source "gnu/system/examples"))
 130
 131   (define build
 132     (with-imported-modules '((guix build utils))
 133       #~(begin
 134           (use-modules (guix build utils)
 135                        (srfi srfi-19))
 136
 137           (define (make-version-texi language)
 138             ;; Create the 'version.texi' file for LANGUAGE.
 139             (let ((file (if (string=? language "en")
 140                             "version.texi"
 141                             (string-append "version-" language ".texi"))))
 142               (call-with-output-file (string-append #$output "/" file)
 143                 (lambda (port)
 144                   (let* ((version #$version)
 145                          (time    (make-time time-utc 0 #$date))
 146                          (date    (time-utc->date time)))
 147                     (format port "
 148 @set UPDATED ~a
 149 @set UPDATED-MONTH ~a
 150 @set EDITION ~a
 151 @set VERSION ~a\n"
 152                             (date->string date "~e ~B ~Y")
 153                             (date->string date "~B ~Y")
 154                             version version))))))
 155
 156           (install-file #$(file-append documentation "/htmlxref.cnf")
 157                         #$output)
 158
 159           (for-each (lambda (texi)
 160                       (install-file texi #$output))
 161                     (append (find-files #$documentation "\\.(texi|scm|json)$")
 162                             (find-files #$(translated-texi-manuals source)
 163                                         "\\.texi$")))
 164
 165           ;; Create 'version.texi'.
 166           (for-each make-version-texi '#$languages)
 167
 168           ;; Copy configuration templates that the manual includes.
 169           (for-each (lambda (template)
 170                       (copy-file template
 171                                  (string-append
 172                                   #$output "/os-config-"
 173                                   (basename template ".tmpl")
 174                                   ".texi")))
 175                     (find-files #$examples "\\.tmpl$"))
 176
 177           (symlink #$(texinfo-manual-images source)
 178                    (string-append #$output "/images")))))
 179
 180   (computed-file "texinfo-manual-source" build))
 181
 182 (define %web-site-url
 183   ;; URL of the web site home page.
 184   (or (getenv "GUIX_WEB_SITE_URL")
 185       "/software/guix/"))
 186
 187 (define %makeinfo-html-options
 188   ;; Options passed to 'makeinfo --html'.
 189   '("--css-ref=https://www.gnu.org/software/gnulib/manual.css"
 190     "-c" "EXTRA_HEAD=<meta name=\"viewport\" \
 191 content=\"width=device-width, initial-scale=1\" />"))
 192
 193 (define (normalize-language-code language)        ;XXX: deduplicate
 194   ;; Normalize LANGUAGE.  For instance, "zh_CN" becomes "zh-cn".
 195   (string-map (match-lambda
 196                 (#\_ #\-)
 197                 (chr chr))
 198               (string-downcase language)))
 199
 200 (define* (html-manual-identifier-index manual base-url
 201                                        #:key
 202                                        (name "html-manual-identifier-index"))
 203   "Return an index of all the identifiers that appear in MANUAL, a
 204 makeinfo-generated manual.  The index is a file that contains an alist; each
 205 key is an identifier and the associated value is the URL reference pointing to
 206 that identifier.  The URL is constructed by concatenating BASE-URL to the
 207 actual file name."
 208   (define build
 209     (with-extensions (list guile-lib)
 210       (with-imported-modules '((guix build utils))
 211         #~(begin
 212             (use-modules (guix build utils)
 213                          (htmlprag)
 214                          (srfi srfi-1)
 215                          (srfi srfi-26)
 216                          (ice-9 ftw)
 217                          (ice-9 match)
 218                          (ice-9 threads)
 219                          (ice-9 pretty-print))
 220
 221             (%strict-tokenizer? #t)
 222
 223             (define file-url
 224               (let ((prefix (string-append #$manual "/")))
 225                 (lambda (file)
 226                   ;; Return the URL for FILE.
 227                   (let ((file (string-drop file (string-length prefix)))
 228                         (base #$base-url))
 229                     (if (string-null? base)
 230                         file
 231                         (string-append base "/" file))))))
 232
 233             (define (underscore-decode str)
 234               ;; Decode STR, an "underscore-encoded" string as produced by
 235               ;; makeinfo for indexes, such as "_0025base_002dservices" for
 236               ;; "%base-services".
 237               (let loop ((str str)
 238                          (result '()))
 239                 (match (string-index str #\_)
 240                   (#f
 241                    (string-concatenate-reverse (cons str result)))
 242                   (index
 243                    (let ((char (string->number
 244                                 (substring str (+ index 1) (+ index 5))
 245                                 16)))
 246                      (loop (string-drop str (+ index 5))
 247                            (append (list (string (integer->char char))
 248                                          (string-take str index))
 249                                    result)))))))
 250
 251             (define (anchor-id->key id)
 252               ;; Convert ID, an anchor ID such as
 253               ;; "index-pam_002dlimits_002dservice" to the corresponding key,
 254               ;; "pam-limits-service" in this example.  Drop the suffix of
 255               ;; duplicate anchor IDs like "operating_002dsystem-1".
 256               (let ((id (if (any (cut string-suffix? <> id)
 257                                  '("-1" "-2" "-3" "-4" "-5"))
 258                             (string-drop-right id 2)
 259                             id)))
 260                 (underscore-decode
 261                  (string-drop id (string-length "index-")))))
 262
 263             (define* (collect-anchors file #:optional (anchors '()))
 264               ;; Collect the anchors that appear in FILE, a makeinfo-generated
 265               ;; file.  Grab those from <dt> tags, which corresponds to
 266               ;; Texinfo @deftp, @defvr, etc.  Return ANCHORS augmented with
 267               ;; more name/reference pairs.
 268               (define string-or-entity?
 269                 (match-lambda
 270                   ((? string?) #t)
 271                   (('*ENTITY* _ ...) #t)
 272                   (_ #f)))
 273
 274               (define (worthy-entry? lst)
 275                 ;; Attempt to match:
 276                 ;;   Scheme Variable: <strong>x</strong>
 277                 ;; but not:
 278                 ;;   <code>cups-configuration</code> parameter: …
 279                 (let loop ((lst lst))
 280                   (match lst
 281                     (((? string-or-entity?) rest ...)
 282                      (loop rest))
 283                     ((('strong _ ...) _ ...)
 284                      #t)
 285                     ((('span ('@ ('class "symbol-definition-category"))
 286                              (? string-or-entity?) ...) rest ...)
 287                      #t)
 288                     (x
 289                      #f))))
 290
 291               (let ((shtml (call-with-input-file file html->shtml)))
 292                 (let loop ((shtml shtml)
 293                            (anchors anchors))
 294                   (match shtml
 295                     (('dt ('@ ('id id) _ ...) rest ...)
 296                      (if (and (string-prefix? "index-" id)
 297                               (worthy-entry? rest))
 298                          (alist-cons (anchor-id->key id)
 299                                      (string-append (file-url file)
 300                                                     "#" id)
 301                                      anchors)
 302                          anchors))
 303                     ((tag ('@ _ ...) body ...)
 304                      (fold loop anchors body))
 305                     ((tag body ...)
 306                      (fold loop anchors body))
 307                     (_ anchors)))))
 308
 309             (define (html-files directory)
 310               ;; Return the list of HTML files under DIRECTORY.
 311               (map (cut string-append directory "/" <>)
 312                    (or (scandir #$manual (lambda (file)
 313                                            (string-suffix? ".html" file)))
 314                        '())))
 315
 316             (define anchors
 317               (sort (concatenate
 318                      (n-par-map (parallel-job-count)
 319                                 (cut collect-anchors <>)
 320                                 (html-files #$manual)))
 321                     (match-lambda*
 322                       (((key1 . url1) (key2 . url2))
 323                        (if (string=? key1 key2)
 324                            (string<? url1 url2)
 325                            (string<? key1 key2))))))
 326
 327             (call-with-output-file #$output
 328               (lambda (port)
 329                 (display ";; Identifier index for the manual.\n\n"
 330                          port)
 331                 (pretty-print anchors port)))))))
 332
 333   (computed-file name build))
 334
 335 (define* (html-identifier-indexes manual directory-suffix
 336                                   #:key (languages %languages)
 337                                   (manual-name %manual)
 338                                   (base-url (const "")))
 339   (map (lambda (language)
 340          (let ((language (normalize-language-code language)))
 341            (list language
 342                  (html-manual-identifier-index
 343                   (file-append manual "/" language directory-suffix)
 344                   (base-url language)
 345                   #:name (string-append manual-name "-html-index-"
 346                                         language)))))
 347        languages))
 348
 349 (define* (syntax-highlighted-html input
 350                                   #:key
 351                                   (name "highlighted-syntax")
 352                                   (languages %languages)
 353                                   (mono-node-indexes
 354                                    (html-identifier-indexes input ""
 355                                                             #:languages
 356                                                             languages))
 357                                   (split-node-indexes
 358                                    (html-identifier-indexes input
 359                                                             "/html_node"
 360                                                             #:languages
 361                                                             languages))
 362                                   (syntax-css-url
 363                                    "/static/base/css/code.css"))
 364   "Return a derivation called NAME that processes all the HTML files in INPUT
 365 to (1) add them a link to SYNTAX-CSS-URL, and (2) highlight the syntax of all
 366 its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
 367   (define build
 368     (with-extensions (list guile-lib guile-syntax-highlight)
 369       (with-imported-modules '((guix build utils))
 370         #~(begin
 371             (use-modules (htmlprag)
 372                          (syntax-highlight)
 373                          (syntax-highlight scheme)
 374                          (syntax-highlight lexers)
 375                          (guix build utils)
 376                          (srfi srfi-1)
 377                          (srfi srfi-26)
 378                          (ice-9 match)
 379                          (ice-9 threads)
 380                          (ice-9 vlist))
 381
 382             (%strict-tokenizer? #t)
 383
 384             (define (pair-open/close lst)
 385               ;; Pair 'open' and 'close' tags produced by 'highlights' and
 386               ;; produce nested 'paren' tags instead.
 387               (let loop ((lst lst)
 388                          (level 0)
 389                          (result '()))
 390                 (match lst
 391                   ((('open open) rest ...)
 392                    (call-with-values
 393                        (lambda ()
 394                          (loop rest (+ 1 level) '()))
 395                      (lambda (inner close rest)
 396                        (loop rest level
 397                              (cons `(paren ,level ,open ,inner ,close)
 398                                    result)))))
 399                   ((('close str) rest ...)
 400                    (if (> level 0)
 401                        (values (reverse result) str rest)
 402                        (begin
 403                          (format (current-error-port)
 404                                  "warning: extra closing paren; context:~% ~y~%"
 405                                  (reverse result))
 406                          (loop rest 0 (cons `(close ,str) result)))))
 407                   ((item rest ...)
 408                    (loop rest level (cons item result)))
 409                   (()
 410                    (when (> level 0)
 411                      (format (current-error-port)
 412                              "warning: missing ~a closing parens; context:~% ~y%"
 413                              level (reverse result)))
 414                    (values (reverse result) "" '())))))
 415
 416             (define (highlights->sxml* highlights anchors)
 417               ;; Like 'highlights->sxml', but handle nested 'paren tags.  This
 418               ;; allows for paren matching highlights via appropriate CSS
 419               ;; "hover" properties.  When a symbol is encountered, look it up
 420               ;; in ANCHORS, a vhash, and emit the corresponding href, if any.
 421               (define (tag->class tag)
 422                 (string-append "syntax-" (symbol->string tag)))
 423
 424               (map (match-lambda
 425                      ((? string? str) str)
 426                      (('paren level open (body ...) close)
 427                       `(span (@ (class ,(string-append "syntax-paren"
 428                                                        (number->string level))))
 429                              ,open
 430                              (span (@ (class "syntax-symbol"))
 431                                    ,@(highlights->sxml* body anchors))
 432                              ,close))
 433                      (('symbol text)
 434                       ;; Check whether we can emit a hyperlink for TEXT.
 435                       (match (vhash-assoc text anchors)
 436                         (#f
 437                          `(span (@ (class ,(tag->class 'symbol))) ,text))
 438                         ((_ . target)
 439                          `(a (@ (class ,(tag->class 'symbol)) (href ,target))
 440                              ,text))))
 441                      ((tag text)
 442                       `(span (@ (class ,(tag->class tag))) ,text)))
 443                    highlights))
 444
 445             (define entity->string
 446               (match-lambda
 447                 ("rArr"   "⇒")
 448                 ("rarr"   "→")
 449                 ("hellip" "…")
 450                 ("rsquo"  "’")
 451                 ("nbsp"   " ")
 452                 (e (pk 'unknown-entity e) (primitive-exit 2))))
 453
 454             (define (concatenate-snippets pieces)
 455               ;; Concatenate PIECES, which contains strings and entities,
 456               ;; replacing entities with their corresponding string.
 457               (let loop ((pieces pieces)
 458                          (strings '()))
 459                 (match pieces
 460                   (()
 461                    (string-concatenate-reverse strings))
 462                   (((? string? str) . rest)
 463                    (loop rest (cons str strings)))
 464                   ((('*ENTITY* "additional" entity) . rest)
 465                    (loop rest (cons (entity->string entity) strings)))
 466                   ((('span _ lst ...) . rest)     ;for <span class="roman">
 467                    (loop (append lst rest) strings))
 468                   ((('var name) . rest)           ;for @var{name} within @lisp
 469                    (loop rest (cons name strings))) ;XXX: losing formatting
 470                   (something
 471                    (pk 'unsupported-code-snippet something)
 472                    (primitive-exit 1)))))
 473
 474             (define (highlight-definition id category symbol args)
 475               ;; Produce stylable HTML for the given definition (an @deftp,
 476               ;; @deffn, or similar).
 477               `(dt (@ (id ,id) (class "symbol-definition"))
 478                    (span (@ (class "symbol-definition-category"))
 479                          ,@category)
 480                    (span (@ (class "symbol-definition-prototype"))
 481                          ,symbol " " ,@args)))
 482
 483             (define (space? obj)
 484               (and (string? obj)
 485                    (string-every char-set:whitespace obj)))
 486
 487             (define (syntax-highlight sxml anchors)
 488               ;; Recurse over SXML and syntax-highlight code snippets.
 489               (let loop ((sxml sxml))
 490                 (match sxml
 491                   (('*TOP* decl body ...)
 492                    `(*TOP* ,decl ,@(map loop body)))
 493                   (('head things ...)
 494                    `(head ,@things
 495                           (link (@ (rel "stylesheet")
 496                                    (type "text/css")
 497                                    (href #$syntax-css-url)))))
 498                   (('pre ('@ ('class "lisp")) code-snippet ...)
 499                    `(pre (@ (class "lisp"))
 500                          ,@(highlights->sxml*
 501                             (pair-open/close
 502                              (highlight lex-scheme
 503                                         (concatenate-snippets code-snippet)))
 504                             anchors)))
 505
 506                   ;; Replace the ugly <strong> used for @deffn etc., which
 507                   ;; translate to <dt>, with more stylable markup.
 508                   (('dt (@ ('id id)) category ... ('strong thing))
 509                    (highlight-definition id category thing '()))
 510                   (('dt (@ ('id id)) category ... ('strong thing)
 511                         (? space?) ('em args ...))
 512                    (highlight-definition id category thing args))
 513
 514                   ((tag ('@ attributes ...) body ...)
 515                    `(,tag (@ ,@attributes) ,@(map loop body)))
 516                   ((tag body ...)
 517                    `(,tag ,@(map loop body)))
 518                   ((? string? str)
 519                    str))))
 520
 521             (define (process-html file anchors)
 522               ;; Parse FILE and perform syntax highlighting for its Scheme
 523               ;; snippets.  Install the result to #$output.
 524               (format (current-error-port) "processing ~a...~%" file)
 525               (let* ((shtml        (call-with-input-file file html->shtml))
 526                      (highlighted  (syntax-highlight shtml anchors))
 527                      (base         (string-drop file (string-length #$input)))
 528                      (target       (string-append #$output base)))
 529                 (mkdir-p (dirname target))
 530                 (call-with-output-file target
 531                   (lambda (port)
 532                     (write-shtml-as-html highlighted port)))))
 533
 534             (define (copy-as-is file)
 535               ;; Copy FILE as is to #$output.
 536               (let* ((base   (string-drop file (string-length #$input)))
 537                      (target (string-append #$output base)))
 538                 (mkdir-p (dirname target))
 539                 (catch 'system-error
 540                   (lambda ()
 541                     (if (eq? 'symlink (stat:type (lstat file)))
 542                         (symlink (readlink file) target)
 543                         (link file target)))
 544                   (lambda args
 545                     (let ((errno (system-error-errno args)))
 546                       (pk 'error-link file target (strerror errno))
 547                       (primitive-exit 3))))))
 548
 549             (define (html? file stat)
 550               (string-suffix? ".html" file))
 551
 552             (define language+node-anchors
 553               (match-lambda
 554                 ((language files ...)
 555                  (cons language
 556                        (fold (lambda (file vhash)
 557                                (let ((alist (call-with-input-file file read)))
 558                                  ;; Use 'fold-right' so that the first entry
 559                                  ;; wins (e.g., "car" from "Pairs" rather than
 560                                  ;; from "rnrs base" in the Guile manual).
 561                                  (fold-right (match-lambda*
 562                                                (((key . value) vhash)
 563                                                 (vhash-cons key value vhash)))
 564                                              vhash
 565                                              alist)))
 566                              vlist-null
 567                              files)))))
 568
 569             (define mono-node-anchors
 570               ;; List of language/vhash pairs, where each vhash maps an
 571               ;; identifier to the corresponding URL in a single-page manual.
 572               (map language+node-anchors '#$mono-node-indexes))
 573
 574             (define multi-node-anchors
 575               ;; Likewise for split-node manuals.
 576               (map language+node-anchors '#$split-node-indexes))
 577
 578             ;; Install a UTF-8 locale so we can process UTF-8 files.
 579             (setenv "GUIX_LOCPATH"
 580                     #+(file-append glibc-utf8-locales "/lib/locale"))
 581             (setlocale LC_ALL "en_US.utf8")
 582
 583             ;; First process the mono-node 'guix.html' files.
 584             (for-each (match-lambda
 585                         ((language . anchors)
 586                          (let ((files (find-files
 587                                        (string-append #$input "/" language)
 588                                        "^guix(-cookbook|)(\\.[a-zA-Z_-]+)?\\.html$")))
 589                            (n-par-for-each (parallel-job-count)
 590                                            (cut process-html <> anchors)
 591                                            files))))
 592                       mono-node-anchors)
 593
 594             ;; Process the multi-node HTML files.
 595             (for-each (match-lambda
 596                         ((language . anchors)
 597                          (let ((files (find-files
 598                                        (string-append #$input "/" language
 599                                                       "/html_node")
 600                                        "\\.html$")))
 601                            (n-par-for-each (parallel-job-count)
 602                                            (cut process-html <> anchors)
 603                                            files))))
 604                       multi-node-anchors)
 605
 606             ;; Last, copy non-HTML files as is.
 607             (for-each copy-as-is
 608                       (find-files #$input (negate html?)))))))
 609
 610   (computed-file name build))
 611
 612 (define* (stylized-html source input
 613                         #:key
 614                         (languages %languages)
 615                         (manual %manual)
 616                         (manual-css-url "/static/base/css/manual.css"))
 617   "Process all the HTML files in INPUT; add them MANUAL-CSS-URL as a <style>
 618 link, and add a menu to choose among LANGUAGES.  Use the Guix PO files found
 619 in SOURCE."
 620   (define build
 621     (with-extensions (list guile-lib)
 622       (with-imported-modules `((guix build utils)
 623                                ((localization)
 624                                 => ,(localization-helper-module
 625                                      source languages)))
 626         #~(begin
 627             (use-modules (htmlprag)
 628                          (localization)
 629                          (guix build utils)
 630                          (srfi srfi-1)
 631                          (ice-9 match)
 632                          (ice-9 threads))
 633
 634             (define* (menu-dropdown #:key (label "Item") (url "#") (items '()))
 635               ;; Return an SHTML <li> element representing a dropdown for the
 636               ;; navbar.  LABEL is the text of the dropdown menu, and ITEMS is
 637               ;; the list of items in this menu.
 638               (define id "visible-dropdown")
 639
 640               `(li
 641                 (@ (class "navbar-menu-item dropdown dropdown-btn"))
 642                 (input (@ (class "navbar-menu-hidden-input")
 643                           (type "radio")
 644                           (name "dropdown")
 645                           (id ,id)))
 646                 (label (@ (for ,id)) ,label)
 647                 (label (@ (for "all-dropdowns-hidden")) ,label)
 648                 (div
 649                  (@ (class "navbar-submenu")
 650                     (id "navbar-submenu"))
 651                  (div (@ (class "navbar-submenu-triangle"))
 652                       " ")
 653                  (ul ,@items))))
 654
 655             (define (menu-item label url)
 656               ;; Return an SHTML <li> element for a menu item with the given
 657               ;; LABEL and URL.
 658               `(li (a (@ (class "navbar-menu-item")
 659                          (href ,url))
 660                       ,label)))
 661
 662             (define* (navigation-bar menus #:key split-node?)
 663               ;; Return the navigation bar showing all of MENUS.
 664               `(header (@ (class "navbar"))
 665                        (h1 (a (@ (class "branding")
 666                                  (href ,(if split-node? ".." "#")))))
 667                        (nav (@ (class "navbar-menu"))
 668                             (input (@ (class "navbar-menu-hidden-input")
 669                                       (type "radio")
 670                                       (name "dropdown")
 671                                       (id "all-dropdowns-hidden")))
 672                             (ul ,@menus))
 673
 674                        ;; This is the button that shows up on small screen in
 675                        ;; lieu of the drop-down button.
 676                        (a (@ (class "navbar-menu-btn")
 677                              (href ,(if split-node? "../.." ".."))))))
 678
 679             (define* (base-language-url code manual
 680                                         #:key split-node?)
 681               ;; Return the base URL of MANUAL for language CODE.
 682               (if split-node?
 683                   (string-append "../../" (normalize code) "/html_node")
 684                   (string-append "../" (normalize code) "/" manual
 685                                  (if (string=? code "en")
 686                                      ""
 687                                      (string-append "." code))
 688                                  ".html")))
 689
 690             (define (language-menu-items file)
 691               ;; Return the language menu items to be inserted in FILE.
 692               (define split-node?
 693                 (string-contains file "/html_node/"))
 694
 695               (append
 696                   (map (lambda (code)
 697                          (menu-item (language-code->native-name code)
 698                                     (base-language-url code #$manual
 699                                                        #:split-node?
 700                                                        split-node?)))
 701                        '#$%languages)
 702                   (list
 703                    (menu-item "⊕"
 704                               (if (string=? #$manual "guix-cookbook")
 705                                   "https://translate.fedoraproject.org/projects/guix/documentation-cookbook/"
 706                                   "https://translate.fedoraproject.org/projects/guix/documentation-manual/")))))
 707
 708             (define (stylized-html sxml file)
 709               ;; Return SXML, which was read from FILE, with additional
 710               ;; styling.
 711               (define split-node?
 712                 (string-contains file "/html_node/"))
 713
 714               (let loop ((sxml sxml))
 715                 (match sxml
 716                   (('*TOP* decl body ...)
 717                    `(*TOP* ,decl ,@(map loop body)))
 718                   (('head elements ...)
 719                    ;; Add reference to our own manual CSS, which provides
 720                    ;; support for the language menu.
 721                    `(head ,@elements
 722                           (link (@ (rel "stylesheet")
 723                                    (type "text/css")
 724                                    (href #$manual-css-url)))))
 725                   (('body ('@ attributes ...) elements ...)
 726                    `(body (@ ,@attributes)
 727                           ,(navigation-bar
 728                             ;; TODO: Add "Contribute" menu, to report
 729                             ;; errors, etc.
 730                             (list (menu-dropdown
 731                                    #:label
 732                                    `(img (@ (alt "Language")
 733                                             (src "/static/base/img/language-picker.svg")))
 734                                    #:items
 735                                    (language-menu-items file)))
 736                             #:split-node? split-node?)
 737                           ,@elements))
 738                   ((tag ('@ attributes ...) body ...)
 739                    `(,tag (@ ,@attributes) ,@(map loop body)))
 740                   ((tag body ...)
 741                    `(,tag ,@(map loop body)))
 742                   ((? string? str)
 743                    str))))
 744
 745             (define (process-html file)
 746               ;; Parse FILE and add links to translations.  Install the result
 747               ;; to #$output.
 748               (format (current-error-port) "processing ~a...~%" file)
 749               (let* ((shtml        (parameterize ((%strict-tokenizer? #t))
 750                                      (call-with-input-file file html->shtml)))
 751                      (processed    (stylized-html shtml file))
 752                      (base         (string-drop file (string-length #$input)))
 753                      (target       (string-append #$output base)))
 754                 (mkdir-p (dirname target))
 755                 (call-with-output-file target
 756                   (lambda (port)
 757                     (write-shtml-as-html processed port)))))
 758
 759             ;; Install a UTF-8 locale so we can process UTF-8 files.
 760             (setenv "GUIX_LOCPATH"
 761                     #+(file-append glibc-utf8-locales "/lib/locale"))
 762             (setlocale LC_ALL "en_US.utf8")
 763             (setenv "LC_ALL" "en_US.utf8")
 764             (setvbuf (current-error-port) 'line)
 765
 766             (n-par-for-each (parallel-job-count)
 767                             (lambda (file)
 768                               (if (string-suffix? ".html" file)
 769                                   (process-html file)
 770                                   ;; Copy FILE as is to #$output.
 771                                   (let* ((base   (string-drop file (string-length #$input)))
 772                                          (target (string-append #$output base)))
 773                                     (mkdir-p (dirname target))
 774                                     (if (eq? 'symlink (stat:type (lstat file)))
 775                                         (symlink (readlink file) target)
 776                                         (copy-file file target)))))
 777                             (find-files #$input))))))
 778
 779   (computed-file "stylized-html-manual" build))
 780
 781 (define* (html-manual source #:key (languages %languages)
 782                       (version "0.0")
 783                       (manual %manual)
 784                       (mono-node-indexes (map list languages))
 785                       (split-node-indexes (map list languages))
 786                       (date 1)
 787                       (options %makeinfo-html-options))
 788   "Return the HTML manuals built from SOURCE for all LANGUAGES, with the given
 789 makeinfo OPTIONS."
 790   (define manual-source
 791     (texinfo-manual-source source
 792                            #:version version
 793                            #:languages languages
 794                            #:date date))
 795
 796   (define images
 797     (texinfo-manual-images source))
 798
 799   (define build
 800     (with-imported-modules '((guix build utils))
 801       #~(begin
 802           (use-modules (guix build utils)
 803                        (ice-9 match))
 804
 805           (define (normalize language)
 806             ;; Normalize LANGUAGE.  For instance, "zh_CN" becomes "zh-cn".
 807             (string-map (match-lambda
 808                           (#\_ #\-)
 809                           (chr chr))
 810                         (string-downcase language)))
 811
 812           (define (language->texi-file-name language)
 813             (if (string=? language "en")
 814                 (string-append #$manual-source "/"
 815                                #$manual ".texi")
 816                 (string-append #$manual-source "/"
 817                                #$manual "." language ".texi")))
 818
 819           ;; Install a UTF-8 locale so that 'makeinfo' is at ease.
 820           (setenv "GUIX_LOCPATH"
 821                   #+(file-append glibc-utf8-locales "/lib/locale"))
 822           (setenv "LC_ALL" "en_US.utf8")
 823
 824           (setvbuf (current-output-port) 'line)
 825           (setvbuf (current-error-port) 'line)
 826
 827           ;; 'makeinfo' looks for "htmlxref.cnf" in the current directory, so
 828           ;; copy it right here.
 829           (copy-file (string-append #$manual-source "/htmlxref.cnf")
 830                      "htmlxref.cnf")
 831
 832           (for-each (lambda (language)
 833                       (let* ((texi (language->texi-file-name language))
 834                              (opts `("--html"
 835                                      "-c" ,(string-append "TOP_NODE_UP_URL=/manual/"
 836                                                          language)
 837                                      #$@options
 838                                      ,texi)))
 839                         (format #t "building HTML manual for language '~a'...~%"
 840                                 language)
 841                         (mkdir-p (string-append #$output "/"
 842                                                 (normalize language)))
 843                         (setenv "LANGUAGE" language)
 844                         (apply invoke #$(file-append texinfo "/bin/makeinfo")
 845                                "-o" (string-append #$output "/"
 846                                                    (normalize language)
 847                                                    "/html_node")
 848                                opts)
 849                         (apply invoke #$(file-append texinfo "/bin/makeinfo")
 850                                "--no-split"
 851                                "-o"
 852                                (string-append #$output "/"
 853                                               (normalize language)
 854                                               "/" #$manual
 855                                               (if (string=? language "en")
 856                                                   ""
 857                                                   (string-append "." language))
 858                                               ".html")
 859                                opts)
 860
 861                         ;; Make sure images are available.
 862                         (symlink #$images
 863                                  (string-append #$output "/" (normalize language)
 864                                                 "/images"))
 865                         (symlink #$images
 866                                  (string-append #$output "/" (normalize language)
 867                                                 "/html_node/images"))))
 868                     (filter (compose file-exists? language->texi-file-name)
 869                             '#$languages)))))
 870
 871   (let* ((name    (string-append manual "-html-manual"))
 872          (manual* (computed-file name build #:local-build? #f)))
 873     (syntax-highlighted-html (stylized-html source manual*
 874                                             #:languages languages
 875                                             #:manual manual)
 876                              #:mono-node-indexes mono-node-indexes
 877                              #:split-node-indexes split-node-indexes
 878                              #:name (string-append name "-highlighted"))))
 879
 880 (define* (pdf-manual source #:key (languages %languages)
 881                      (version "0.0")
 882                      (manual %manual)
 883                      (date 1)
 884                      (options '()))
 885   "Return the HTML manuals built from SOURCE for all LANGUAGES, with the given
 886 makeinfo OPTIONS."
 887   (define manual-source
 888     (texinfo-manual-source source
 889                            #:version version
 890                            #:languages languages
 891                            #:date date))
 892
 893   ;; FIXME: This union works, except for the table of contents of non-English
 894   ;; manuals, which contains escape sequences like "^^ca^^fe" instead of
 895   ;; accented letters.
 896   ;;
 897   ;; (define texlive
 898   ;;   (texlive-updmap.cfg (list texlive-tex-texinfo
 899   ;;                        texlive-generic-epsf
 900   ;;                        texlive-fonts-ec)))
 901
 902   (define build
 903     (with-imported-modules '((guix build utils))
 904       #~(begin
 905           (use-modules (guix build utils)
 906                        (srfi srfi-34)
 907                        (ice-9 match))
 908
 909           (define (normalize language)            ;XXX: deduplicate
 910             ;; Normalize LANGUAGE.  For instance, "zh_CN" becomes "zh-cn".
 911             (string-map (match-lambda
 912                           (#\_ #\-)
 913                           (chr chr))
 914                         (string-downcase language)))
 915
 916           ;; Install a UTF-8 locale so that 'makeinfo' is at ease.
 917           (setenv "GUIX_LOCPATH"
 918                   #+(file-append glibc-utf8-locales "/lib/locale"))
 919           (setenv "LC_ALL" "en_US.utf8")
 920           (setenv "PATH"
 921                   (string-append #+(file-append texlive "/bin") ":"
 922                                  #+(file-append texinfo "/bin") ":"
 923
 924                                  ;; Below are command-line tools needed by
 925                                  ;; 'texi2dvi' and friends.
 926                                  #+(file-append sed "/bin") ":"
 927                                  #+(file-append grep "/bin") ":"
 928                                  #+(file-append coreutils "/bin") ":"
 929                                  #+(file-append gawk "/bin") ":"
 930                                  #+(file-append tar "/bin") ":"
 931                                  #+(file-append diffutils "/bin")))
 932
 933           (setvbuf (current-output-port) 'line)
 934           (setvbuf (current-error-port) 'line)
 935
 936           (setenv "HOME" (getcwd))                ;for kpathsea/mktextfm
 937
 938           ;; 'SOURCE_DATE_EPOCH' is honored by pdftex.
 939           (setenv "SOURCE_DATE_EPOCH" "1")
 940
 941           (for-each (lambda (language)
 942                       (let ((opts `("--pdf"
 943                                     "-I" "."
 944                                     #$@options
 945                                     ,(if (string=? language "en")
 946                                          (string-append #$manual-source "/"
 947                                                         #$manual ".texi")
 948                                          (string-append #$manual-source "/"
 949                                                         #$manual "." language ".texi")))))
 950                         (format #t "building PDF manual for language '~a'...~%"
 951                                 language)
 952                         (mkdir-p (string-append #$output "/"
 953                                                 (normalize language)))
 954                         (setenv "LANGUAGE" language)
 955
 956
 957                         ;; FIXME: Unfortunately building PDFs for non-Latin
 958                         ;; alphabets doesn't work:
 959                         ;; <https://lists.gnu.org/archive/html/help-texinfo/2012-01/msg00014.html>.
 960                         (guard (c ((invoke-error? c)
 961                                    (format (current-error-port)
 962                                            "~%~%Failed to produce \
 963 PDF for language '~a'!~%~%"
 964                                            language)))
 965                          (apply invoke #$(file-append texinfo "/bin/makeinfo")
 966                                 "--pdf" "-o"
 967                                 (string-append #$output "/"
 968                                                (normalize language)
 969                                                "/" #$manual
 970                                                (if (string=? language "en")
 971                                                    ""
 972                                                    (string-append "."
 973                                                                   language))
 974                                                ".pdf")
 975                                 opts))))
 976                     '#$languages))))
 977
 978   (computed-file (string-append manual "-pdf-manual") build
 979                  #:local-build? #f))
 980
 981 (define* (guix-manual-text-domain source
 982                                   #:optional (languages %manual-languages))
 983   "Return the PO files for LANGUAGES of the 'guix-manual' text domain taken
 984 from SOURCE."
 985   (define po-directory
 986     (file-append* source "/po/doc"))
 987
 988   (define build
 989     (with-imported-modules '((guix build utils))
 990       #~(begin
 991           (use-modules (guix build utils))
 992
 993           (mkdir-p #$output)
 994           (for-each (lambda (language)
 995                       (define directory
 996                         (string-append #$output "/" language
 997                                        "/LC_MESSAGES"))
 998
 999                       (mkdir-p directory)
1000                       (invoke #+(file-append gnu-gettext "/bin/msgfmt")
1001                               "-c" "-o"
1002                               (string-append directory "/guix-manual.mo")
1003                               (string-append #$po-directory "/guix-manual."
1004                                              language ".po")))
1005                     '#$(delete "en" languages)))))
1006
1007   (computed-file "guix-manual-po" build))
1008
1009 (define* (localization-helper-module source
1010                                      #:optional (languages %languages))
1011   "Return a file-like object for use as the (localization) module.  SOURCE
1012 must be the Guix top-level source directory, from which PO files are taken."
1013   (define content
1014     (with-extensions (list guile-json-3)
1015       #~(begin
1016           (define-module (localization)
1017             #:use-module (json)
1018             #:use-module (srfi srfi-1)
1019             #:use-module (srfi srfi-19)
1020             #:use-module (ice-9 match)
1021             #:use-module (ice-9 popen)
1022             #:export (normalize
1023                       with-language
1024                       translate
1025                       language-code->name
1026                       language-code->native-name
1027                       seconds->string))
1028
1029           (define (normalize language)            ;XXX: deduplicate
1030             ;; Normalize LANGUAGE.  For instance, "zh_CN" becomes "zh-cn".
1031             (string-map (match-lambda
1032                           (#\_ #\-)
1033                           (chr chr))
1034                         (string-downcase language)))
1035
1036           (define-syntax-rule (with-language language exp ...)
1037             (let ((lang (getenv "LANGUAGE")))
1038               (dynamic-wind
1039                 (lambda ()
1040                   (setenv "LANGUAGE" language)
1041                   (setlocale LC_MESSAGES))
1042                 (lambda () exp ...)
1043                 (lambda ()
1044                   (if lang
1045                       (setenv "LANGUAGE" lang)
1046                       (unsetenv "LANGUAGE"))
1047                   (setlocale LC_MESSAGES)))))
1048
1049           ;; (put 'with-language 'scheme-indent-function 1)
1050           (define* (translate str language
1051                               #:key (domain "guix-manual"))
1052             (define exp
1053               `(begin
1054                  (bindtextdomain "guix-manual"
1055                                  #+(guix-manual-text-domain source))
1056                  (bindtextdomain "iso_639-3"      ;language names
1057                                  #+(file-append iso-codes
1058                                                 "/share/locale"))
1059                  (setenv "LANGUAGE" ,language)
1060                  (write (gettext ,str ,domain))))
1061
1062             ;; Since the 'gettext' function caches msgid translations,
1063             ;; regardless of $LANGUAGE, we have to spawn a new process each
1064             ;; time we want to translate to a different language.  Bah!
1065             (let* ((pipe (open-pipe* OPEN_READ
1066                                      #+(file-append guile-3.0
1067                                                     "/bin/guile")
1068                                      "-c" (object->string exp)))
1069                    (str  (read pipe)))
1070               (close-pipe pipe)
1071               str))
1072
1073           (define %iso639-languages
1074             (vector->list
1075              (assoc-ref (call-with-input-file
1076                             #+(file-append iso-codes
1077                                            "/share/iso-codes/json/iso_639-3.json")
1078                           json->scm)
1079                         "639-3")))
1080
1081           (define (language-code->name code)
1082             "Return the full name of a language from its ISO-639-3 code."
1083             (let ((code (match (string-index code #\_)
1084                           (#f    code)
1085                           (index (string-take code index)))))
1086               (any (lambda (language)
1087                      (and (string=? (or (assoc-ref language "alpha_2")
1088                                         (assoc-ref language "alpha_3"))
1089                                     code)
1090                           (assoc-ref language "name")))
1091                    %iso639-languages)))
1092
1093           (define (language-code->native-name code)
1094             "Return the name of language CODE in that language."
1095             (translate (language-code->name code) code
1096                        #:domain "iso_639-3"))
1097
1098           (define (seconds->string seconds language)
1099             (let* ((time (make-time time-utc 0 seconds))
1100                    (date (time-utc->date time)))
1101               (with-language language (date->string date "~e ~B ~Y")))))))
1102
1103   (scheme-file "localization.scm" content))
1104
1105 (define* (html-manual-indexes source
1106                               #:key (languages %languages)
1107                               (version "0.0")
1108                               (manual %manual)
1109                               (title (if (string=? "guix" manual)
1110                                          "GNU Guix Reference Manual"
1111                                          "GNU Guix Cookbook"))
1112                               (date 1))
1113   (define build
1114     (with-imported-modules `((guix build utils)
1115                              ((localization)
1116                               => ,(localization-helper-module
1117                                    source languages)))
1118       #~(begin
1119           (use-modules (guix build utils)
1120                        (localization)
1121                        (sxml simple)
1122                        (srfi srfi-1))
1123
1124           (define (guix-url path)
1125             (string-append #$%web-site-url path))
1126
1127           (define (sxml-index language title body)
1128             ;; FIXME: Avoid duplicating styling info from guix-artwork.git.
1129             `(html (@ (lang ,language))
1130                    (head
1131                     (title ,(string-append title " — GNU Guix"))
1132                     (meta (@ (charset "UTF-8")))
1133                     (meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
1134                     ;; Menu prefetch.
1135                     (link (@ (rel "prefetch") (href ,(guix-url "menu/index.html"))))
1136                     ;; Base CSS.
1137                     (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/elements.css"))))
1138                     (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/common.css"))))
1139                     (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/messages.css"))))
1140                     (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/navbar.css"))))
1141                     (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/breadcrumbs.css"))))
1142                     (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/buttons.css"))))
1143                     (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/footer.css"))))
1144
1145                     (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/page.css"))))
1146                     (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/post.css")))))
1147                    (body
1148                     (header (@ (class "navbar"))
1149                             (h1 (a (@ (class "branding")
1150                                       (href #$%web-site-url)))
1151                                 (span (@ (class "a11y-offset"))
1152                                       "Guix"))
1153                             (nav (@ (class "menu"))))
1154                     (nav (@ (class "breadcrumbs"))
1155                          (a (@ (class "crumb")
1156                                (href #$%web-site-url))
1157                             "Home"))
1158                     ,body
1159                     (footer))))
1160
1161           (define (language-index language)
1162             (define title
1163               (translate #$title language))
1164
1165             (sxml-index
1166              language title
1167              `(main
1168                (article
1169                 (@ (class "page centered-block limit-width"))
1170                 (h2 ,title)
1171                 (p (@ (class "post-metadata centered-text"))
1172                    #$version " — "
1173                    ,(seconds->string #$date language))
1174
1175                 (div
1176                  (ul
1177                   (li (a (@ (href "html_node"))
1178                          "HTML, with a separate page per node"))
1179                   (li (a (@ (href
1180                              ,(string-append
1181                                #$manual
1182                                (if (string=? language
1183                                              "en")
1184                                    ""
1185                                    (string-append "."
1186                                                   language))
1187                                ".html")))
1188                          "HTML, entirely on one page"))
1189                   ,@(if (member language '("ru" "zh_CN"))
1190                         '()
1191                         `((li (a (@ (href ,(string-append
1192                                             #$manual
1193                                             (if (string=? language "en")
1194                                                 ""
1195                                                 (string-append "."
1196                                                                language))
1197                                             ".pdf"))))
1198                               "PDF")))))))))
1199
1200           (define (top-level-index languages)
1201             (define title #$title)
1202             (sxml-index
1203              "en" title
1204              `(main
1205                (article
1206                 (@ (class "page centered-block limit-width"))
1207                 (h2 ,title)
1208                 (div
1209                  "This document is available in the following
1210 languages:\n"
1211                  (ul
1212                   ,@(map (lambda (language)
1213                            `(li (a (@ (href ,(normalize language)))
1214                                    ,(language-code->native-name language))))
1215                          languages)))))))
1216
1217           (define (write-html file sxml)
1218             (call-with-output-file file
1219               (lambda (port)
1220                 (display "<!DOCTYPE html>\n" port)
1221                 (sxml->xml sxml port))))
1222
1223           (setenv "GUIX_LOCPATH"
1224                   #+(file-append glibc-utf8-locales "/lib/locale"))
1225           (setenv "LC_ALL" "en_US.utf8")
1226           (setlocale LC_ALL "en_US.utf8")
1227
1228           (for-each (lambda (language)
1229                       (define directory
1230                         (string-append #$output "/"
1231                                        (normalize language)))
1232
1233                       (mkdir-p directory)
1234                       (write-html (string-append directory "/index.html")
1235                                   (language-index language)))
1236                     '#$languages)
1237
1238           (write-html (string-append #$output "/index.html")
1239                       (top-level-index '#$languages)))))
1240
1241   (computed-file "html-indexes" build))
1242
1243 (define* (pdf+html-manual source
1244                           #:key (languages %languages)
1245                           (version "0.0")
1246                           (date (time-second (current-time time-utc)))
1247                           (mono-node-indexes (map list %languages))
1248                           (split-node-indexes (map list %languages))
1249                           (manual %manual))
1250   "Return the union of the HTML and PDF manuals, as well as the indexes."
1251   (directory-union (string-append manual "-manual")
1252                    (map (lambda (proc)
1253                           (proc source
1254                                 #:date date
1255                                 #:languages languages
1256                                 #:version version
1257                                 #:manual manual))
1258                         (list html-manual-indexes
1259                               (lambda (source . args)
1260                                 (apply html-manual source
1261                                        #:mono-node-indexes mono-node-indexes
1262                                        #:split-node-indexes split-node-indexes
1263                                        args))
1264                               pdf-manual))
1265                    #:copy? #t))
1266
1267 (define (latest-commit+date directory)
1268   "Return two values: the last commit ID (a hex string) for DIRECTORY, and its
1269 commit date (an integer)."
1270   (let* ((repository (repository-open directory))
1271          (head       (repository-head repository))
1272          (oid        (reference-target head))
1273          (commit     (commit-lookup repository oid)))
1274     ;; TODO: Use (git describe) when it's widely available.
1275     (values (oid->string oid) (commit-time commit))))
1276
1277 \f
1278 ;;;
1279 ;;; Guile manual.
1280 ;;;
1281
1282 (define guile-manual
1283   ;; The Guile manual as HTML, including both the mono-node "guile.html" and
1284   ;; the split-node "html_node" directory.
1285   (let ((guile guile-3.0-latest))
1286     (computed-file (string-append "guile-manual-" (package-version guile))
1287                    (with-imported-modules '((guix build utils))
1288                      #~(begin
1289                          (use-modules (guix build utils)
1290                                       (ice-9 match))
1291
1292                          (setenv "PATH"
1293                                  (string-append #+tar "/bin:"
1294                                                 #+xz "/bin:"
1295                                                 #+texinfo "/bin"))
1296                          (invoke "tar" "xf" #$(package-source guile))
1297                          (mkdir-p (string-append #$output "/en/html_node"))
1298
1299                          (let* ((texi (find-files "." "^guile\\.texi$"))
1300                                 (documentation (match texi
1301                                                  ((file) (dirname file)))))
1302                            (with-directory-excursion documentation
1303                              (invoke "makeinfo" "--html" "--no-split"
1304                                      "-o" (string-append #$output
1305                                                          "/en/guile.html")
1306                                      "guile.texi")
1307                              (invoke "makeinfo" "--html" "-o" "split"
1308                                      "guile.texi")
1309                              (copy-recursively
1310                               "split"
1311                               (string-append #$output "/en/html_node")))))))))
1312
1313 (define %guile-manual-base-url
1314   "https://www.gnu.org/software/guile/manual")
1315
1316 (define (for-all-languages index)
1317   (map (lambda (language)
1318          (list language index))
1319        %languages))
1320
1321 (define guile-mono-node-indexes
1322   ;; The Guile manual is only available in English so use the same index in
1323   ;; all languages.
1324   (for-all-languages
1325    (html-manual-identifier-index (file-append guile-manual "/en")
1326                                  %guile-manual-base-url
1327                                  #:name "guile-html-index-en")))
1328
1329 (define guile-split-node-indexes
1330   (for-all-languages
1331    (html-manual-identifier-index (file-append guile-manual "/en/html_node")
1332                                  (string-append %guile-manual-base-url
1333                                                 "/html_node")
1334                                  #:name "guile-html-index-en")))
1335
1336 (define (merge-index-alists alist1 alist2)
1337   "Merge ALIST1 and ALIST2, both of which are list of tuples like:
1338
1339   (LANGUAGE INDEX1 INDEX2 ...)
1340
1341 where LANGUAGE is a string like \"en\" and INDEX1 etc. are indexes as returned
1342 by 'html-identifier-indexes'."
1343   (let ((languages (delete-duplicates
1344                     (append (match alist1
1345                               (((languages . _) ...)
1346                                languages))
1347                             (match alist2
1348                               (((languages . _) ...)
1349                                languages))))))
1350     (map (lambda (language)
1351            (cons language
1352                  (append (or (assoc-ref alist1 language) '())
1353                          (or (assoc-ref alist2 language) '()))))
1354          languages)))
1355
1356 \f
1357 (let* ((root (canonicalize-path
1358               (string-append (current-source-directory) "/..")))
1359        (commit date (latest-commit+date root))
1360        (version (or (getenv "GUIX_MANUAL_VERSION")
1361                     (string-take commit 7)))
1362        (select? (let ((vcs? (git-predicate root)))
1363                   (lambda (file stat)
1364                     (and (vcs? file stat)
1365                          ;; Filter out this file.
1366                          (not (string=? (basename file) "build.scm"))))))
1367        (source (local-file root "guix" #:recursive? #t
1368                            #:select? select?)))
1369
1370   (define guix-manual
1371     (html-manual source
1372                  #:manual "guix"
1373                  #:version version
1374                  #:date date))
1375
1376   (define guix-mono-node-indexes
1377     ;; Alist of indexes for GUIX-MANUAL, where each key is a language code and
1378     ;; each value is a file-like object containing the identifier index.
1379     (html-identifier-indexes guix-manual ""
1380                              #:manual-name "guix"
1381                              #:base-url (if (string=? %manual "guix")
1382                                             (const "")
1383                                             (cut string-append
1384                                               "/manual/devel/" <>))
1385                              #:languages %languages))
1386
1387   (define guix-split-node-indexes
1388     ;; Likewise for the split-node variant of GUIX-MANUAL.
1389     (html-identifier-indexes guix-manual "/html_node"
1390                              #:manual-name "guix"
1391                              #:base-url (if (string=? %manual "guix")
1392                                             (const "")
1393                                             (cut string-append
1394                                               "/manual/devel/" <>
1395                                               "/html_node"))
1396                              #:languages %languages))
1397
1398   (define mono-node-indexes
1399     (merge-index-alists guix-mono-node-indexes guile-mono-node-indexes))
1400
1401   (define split-node-indexes
1402     (merge-index-alists guix-split-node-indexes guile-split-node-indexes))
1403
1404   (format (current-error-port)
1405           "building manual from work tree around commit ~a, ~a~%"
1406           commit
1407           (let* ((time (make-time time-utc 0 date))
1408                  (date (time-utc->date time)))
1409             (date->string date "~e ~B ~Y")))
1410
1411   (pdf+html-manual source
1412                    ;; Always use the identifier indexes of GUIX-MANUAL and
1413                    ;; GUILE-MANUAL.  Both "guix" and "guix-cookbook" can
1414                    ;; contain links to definitions that appear in either of
1415                    ;; these two manuals.
1416                    #:mono-node-indexes mono-node-indexes
1417                    #:split-node-indexes split-node-indexes
1418                    #:version version
1419                    #:date date))