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