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