projects/guix·blob ruby-team · refs

1557 lines · 67.9 KiB

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