doc/build.scm

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