Mirror of GNU Guix
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

958 lines
41 KiB

  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. ;; This file contains machinery to build HTML and PDF copies of the manual
  20. ;; that can be readily published on the web site. To do that, run:
  21. ;;
  22. ;; guix build -f build.scm
  23. ;;
  24. ;; The result is a directory hierarchy that can be used as the manual/
  25. ;; sub-directory of the web site.
  26. (use-modules (guix)
  27. (guix gexp)
  28. (guix git)
  29. (guix git-download)
  30. (guix utils)
  31. (git)
  32. (gnu packages base)
  33. (gnu packages gawk)
  34. (gnu packages gettext)
  35. (gnu packages guile)
  36. (gnu packages guile-xyz)
  37. (gnu packages iso-codes)
  38. (gnu packages texinfo)
  39. (gnu packages tex)
  40. (srfi srfi-19)
  41. (srfi srfi-71))
  42. (define file-append*
  43. (@@ (guix self) file-append*))
  44. (define translated-texi-manuals
  45. (@@ (guix self) translate-texi-manuals))
  46. (define info-manual
  47. (@@ (guix self) info-manual))
  48. (define %manual
  49. ;; The manual to build--i.e., the base name of a .texi file, such as "guix"
  50. ;; or "guix-cookbook".
  51. (or (getenv "GUIX_MANUAL")
  52. "guix"))
  53. (define %languages
  54. ;; The cookbook is currently only translated into German.
  55. (if (string=? %manual "guix-cookbook")
  56. '("de" "en")
  57. '("de" "en" "es" "fr" "ru" "zh_CN")))
  58. (define (texinfo-manual-images source)
  59. "Return a directory containing all the images used by the user manual, taken
  60. from SOURCE, the root of the source tree."
  61. (define graphviz
  62. (module-ref (resolve-interface '(gnu packages graphviz))
  63. 'graphviz))
  64. (define images
  65. (file-append* source "doc/images"))
  66. (define build
  67. (with-imported-modules '((guix build utils))
  68. #~(begin
  69. (use-modules (guix build utils)
  70. (srfi srfi-26))
  71. (define (dot->image dot-file format)
  72. (invoke #+(file-append graphviz "/bin/dot")
  73. "-T" format "-Gratio=.9" "-Gnodesep=.005"
  74. "-Granksep=.00005" "-Nfontsize=9"
  75. "-Nheight=.1" "-Nwidth=.1"
  76. "-o" (string-append #$output "/"
  77. (basename dot-file ".dot")
  78. "." format)
  79. dot-file))
  80. ;; Build graphs.
  81. (mkdir-p #$output)
  82. (for-each (lambda (dot-file)
  83. (for-each (cut dot->image dot-file <>)
  84. '("png" "pdf")))
  85. (find-files #$images "\\.dot$"))
  86. ;; Copy other PNGs.
  87. (for-each (lambda (png-file)
  88. (install-file png-file #$output))
  89. (find-files #$images "\\.png$")))))
  90. (computed-file "texinfo-manual-images" build))
  91. (define* (texinfo-manual-source source #:key
  92. (version "0.0")
  93. (languages %languages)
  94. (date 1))
  95. "Gather all the source files of the Texinfo manuals from SOURCE--.texi file
  96. as well as images, OS examples, and translations."
  97. (define documentation
  98. (file-append* source "doc"))
  99. (define examples
  100. (file-append* source "gnu/system/examples"))
  101. (define build
  102. (with-imported-modules '((guix build utils))
  103. #~(begin
  104. (use-modules (guix build utils)
  105. (srfi srfi-19))
  106. (define (make-version-texi language)
  107. ;; Create the 'version.texi' file for LANGUAGE.
  108. (let ((file (if (string=? language "en")
  109. "version.texi"
  110. (string-append "version-" language ".texi"))))
  111. (call-with-output-file (string-append #$output "/" file)
  112. (lambda (port)
  113. (let* ((version #$version)
  114. (time (make-time time-utc 0 #$date))
  115. (date (time-utc->date time)))
  116. (format port "
  117. @set UPDATED ~a
  118. @set UPDATED-MONTH ~a
  119. @set EDITION ~a
  120. @set VERSION ~a\n"
  121. (date->string date "~e ~B ~Y")
  122. (date->string date "~B ~Y")
  123. version version))))))
  124. (install-file #$(file-append documentation "/htmlxref.cnf")
  125. #$output)
  126. (for-each (lambda (texi)
  127. (install-file texi #$output))
  128. (append (find-files #$documentation "\\.(texi|scm|json)$")
  129. (find-files #$(translated-texi-manuals source)
  130. "\\.texi$")))
  131. ;; Create 'version.texi'.
  132. (for-each make-version-texi '#$languages)
  133. ;; Copy configuration templates that the manual includes.
  134. (for-each (lambda (template)
  135. (copy-file template
  136. (string-append
  137. #$output "/os-config-"
  138. (basename template ".tmpl")
  139. ".texi")))
  140. (find-files #$examples "\\.tmpl$"))
  141. (symlink #$(texinfo-manual-images source)
  142. (string-append #$output "/images")))))
  143. (computed-file "texinfo-manual-source" build))
  144. (define %web-site-url
  145. ;; URL of the web site home page.
  146. (or (getenv "GUIX_WEB_SITE_URL")
  147. "/software/guix/"))
  148. (define %makeinfo-html-options
  149. ;; Options passed to 'makeinfo --html'.
  150. '("--css-ref=https://www.gnu.org/software/gnulib/manual.css"
  151. "-c" "EXTRA_HEAD=<meta name=\"viewport\" \
  152. content=\"width=device-width, initial-scale=1\" />"))
  153. (define guile-lib/htmlprag-fixed
  154. ;; Guile-Lib with a hotfix for (htmlprag).
  155. (package
  156. (inherit guile-lib)
  157. (arguments
  158. (substitute-keyword-arguments (package-arguments guile-lib)
  159. ((#:phases phases '%standard-phases)
  160. `(modify-phases ,phases
  161. (add-before 'build 'fix-htmlprag
  162. (lambda _
  163. ;; When parsing
  164. ;; "<body><blockquote><p>foo</p>\n</blockquote></body>",
  165. ;; 'html->shtml' would mistakenly close 'blockquote' right
  166. ;; before <p>. This patch removes 'p' from the
  167. ;; 'parent-constraints' alist to fix that.
  168. (substitute* "src/htmlprag.scm"
  169. (("^[[:blank:]]*\\(p[[:blank:]]+\\. \\(body td th\\)\\).*")
  170. ""))
  171. #t))
  172. (add-before 'check 'skip-known-failure
  173. (lambda _
  174. ;; XXX: The above change causes one test failure among
  175. ;; the htmlprag tests.
  176. (setenv "XFAIL_TESTS" "htmlprag.scm")
  177. #t))))))))
  178. (define* (syntax-highlighted-html input
  179. #:key
  180. (name "highlighted-syntax")
  181. (syntax-css-url
  182. "/static/base/css/code.css"))
  183. "Return a derivation called NAME that processes all the HTML files in INPUT
  184. to (1) add them a link to SYNTAX-CSS-URL, and (2) highlight the syntax of all
  185. its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
  186. (define build
  187. (with-extensions (list guile-lib/htmlprag-fixed guile-syntax-highlight)
  188. (with-imported-modules '((guix build utils))
  189. #~(begin
  190. (use-modules (htmlprag)
  191. (syntax-highlight)
  192. (syntax-highlight scheme)
  193. (syntax-highlight lexers)
  194. (guix build utils)
  195. (srfi srfi-1)
  196. (srfi srfi-26)
  197. (ice-9 match)
  198. (ice-9 threads)
  199. (ice-9 vlist))
  200. (define (pair-open/close lst)
  201. ;; Pair 'open' and 'close' tags produced by 'highlights' and
  202. ;; produce nested 'paren' tags instead.
  203. (let loop ((lst lst)
  204. (level 0)
  205. (result '()))
  206. (match lst
  207. ((('open open) rest ...)
  208. (call-with-values
  209. (lambda ()
  210. (loop rest (+ 1 level) '()))
  211. (lambda (inner close rest)
  212. (loop rest level
  213. (cons `(paren ,level ,open ,inner ,close)
  214. result)))))
  215. ((('close str) rest ...)
  216. (if (> level 0)
  217. (values (reverse result) str rest)
  218. (begin
  219. (format (current-error-port)
  220. "warning: extra closing paren; context:~% ~y~%"
  221. (reverse result))
  222. (loop rest 0 (cons `(close ,str) result)))))
  223. ((item rest ...)
  224. (loop rest level (cons item result)))
  225. (()
  226. (when (> level 0)
  227. (format (current-error-port)
  228. "warning: missing ~a closing parens; context:~% ~y%"
  229. level (reverse result)))
  230. (values (reverse result) "" '())))))
  231. (define (highlights->sxml* highlights anchors)
  232. ;; Like 'highlights->sxml', but handle nested 'paren tags. This
  233. ;; allows for paren matching highlights via appropriate CSS
  234. ;; "hover" properties. When a symbol is encountered, look it up
  235. ;; in ANCHORS, a vhash, and emit the corresponding href, if any.
  236. (define (tag->class tag)
  237. (string-append "syntax-" (symbol->string tag)))
  238. (map (match-lambda
  239. ((? string? str) str)
  240. (('paren level open (body ...) close)
  241. `(span (@ (class ,(string-append "syntax-paren"
  242. (number->string level))))
  243. ,open
  244. (span (@ (class "syntax-symbol"))
  245. ,@(highlights->sxml* body anchors))
  246. ,close))
  247. (('symbol text)
  248. ;; Check whether we can emit a hyperlink for TEXT.
  249. (match (vhash-assoc text anchors)
  250. (#f
  251. `(span (@ (class ,(tag->class 'symbol))) ,text))
  252. ((_ . target)
  253. `(a (@ (class ,(tag->class 'symbol)) (href ,target))
  254. ,text))))
  255. ((tag text)
  256. `(span (@ (class ,(tag->class tag))) ,text)))
  257. highlights))
  258. (define entity->string
  259. (match-lambda
  260. ("rArr" "⇒")
  261. ("rarr" "→")
  262. ("hellip" "…")
  263. ("rsquo" "’")
  264. (e (pk 'unknown-entity e) (primitive-exit 2))))
  265. (define (concatenate-snippets pieces)
  266. ;; Concatenate PIECES, which contains strings and entities,
  267. ;; replacing entities with their corresponding string.
  268. (let loop ((pieces pieces)
  269. (strings '()))
  270. (match pieces
  271. (()
  272. (string-concatenate-reverse strings))
  273. (((? string? str) . rest)
  274. (loop rest (cons str strings)))
  275. ((('*ENTITY* "additional" entity) . rest)
  276. (loop rest (cons (entity->string entity) strings)))
  277. ((('span _ lst ...) . rest) ;for <span class="roman">
  278. (loop (append lst rest) strings))
  279. (something
  280. (pk 'unsupported-code-snippet something)
  281. (primitive-exit 1)))))
  282. (define (syntax-highlight sxml anchors)
  283. ;; Recurse over SXML and syntax-highlight code snippets.
  284. (let loop ((sxml sxml))
  285. (match sxml
  286. (('*TOP* decl body ...)
  287. `(*TOP* ,decl ,@(map loop body)))
  288. (('head things ...)
  289. `(head ,@things
  290. (link (@ (rel "stylesheet")
  291. (type "text/css")
  292. (href #$syntax-css-url)))))
  293. (('pre ('@ ('class "lisp")) code-snippet ...)
  294. `(pre (@ (class "lisp"))
  295. ,@(highlights->sxml*
  296. (pair-open/close
  297. (highlight lex-scheme
  298. (concatenate-snippets code-snippet)))
  299. anchors)))
  300. ((tag ('@ attributes ...) body ...)
  301. `(,tag (@ ,@attributes) ,@(map loop body)))
  302. ((tag body ...)
  303. `(,tag ,@(map loop body)))
  304. ((? string? str)
  305. str))))
  306. (define (underscore-decode str)
  307. ;; Decode STR, an "underscore-encoded" string as produced by
  308. ;; makeinfo for indexes, such as "_0025base_002dservices" for
  309. ;; "%base-services".
  310. (let loop ((str str)
  311. (result '()))
  312. (match (string-index str #\_)
  313. (#f
  314. (string-concatenate-reverse (cons str result)))
  315. (index
  316. (let ((char (string->number
  317. (substring str (+ index 1) (+ index 5))
  318. 16)))
  319. (loop (string-drop str (+ index 5))
  320. (append (list (string (integer->char char))
  321. (string-take str index))
  322. result)))))))
  323. (define (anchor-id->key id)
  324. ;; Convert ID, an anchor ID such as
  325. ;; "index-pam_002dlimits_002dservice" to the corresponding key,
  326. ;; "pam-limits-service" in this example. Drop the suffix of
  327. ;; duplicate anchor IDs like "operating_002dsystem-1".
  328. (let ((id (if (any (cut string-suffix? <> id)
  329. '("-1" "-2" "-3" "-4" "-5"))
  330. (string-drop-right id 2)
  331. id)))
  332. (underscore-decode
  333. (string-drop id (string-length "index-")))))
  334. (define* (collect-anchors file #:optional (vhash vlist-null))
  335. ;; Collect the anchors that appear in FILE, a makeinfo-generated
  336. ;; file. Grab those from <dt> tags, which corresponds to
  337. ;; Texinfo @deftp, @defvr, etc. Return VHASH augmented with
  338. ;; more name/reference pairs.
  339. (define string-or-entity?
  340. (match-lambda
  341. ((? string?) #t)
  342. (('*ENTITY* _ ...) #t)
  343. (_ #f)))
  344. (define (worthy-entry? lst)
  345. ;; Attempt to match:
  346. ;; Scheme Variable: <strong>x</strong>
  347. ;; but not:
  348. ;; <code>cups-configuration</code> parameter: …
  349. (let loop ((lst lst))
  350. (match lst
  351. (((? string-or-entity?) rest ...)
  352. (loop rest))
  353. ((('strong _ ...) _ ...)
  354. #t)
  355. (_ #f))))
  356. (let ((shtml (call-with-input-file file html->shtml)))
  357. (let loop ((shtml shtml)
  358. (vhash vhash))
  359. (match shtml
  360. (('dt ('@ ('id id)) rest ...)
  361. (if (and (string-prefix? "index-" id)
  362. (worthy-entry? rest))
  363. (vhash-cons (anchor-id->key id)
  364. (string-append (basename file)
  365. "#" id)
  366. vhash)
  367. vhash))
  368. ((tag ('@ _ ...) body ...)
  369. (fold loop vhash body))
  370. ((tag body ...)
  371. (fold loop vhash body))
  372. (_ vhash)))))
  373. (define (process-html file anchors)
  374. ;; Parse FILE and perform syntax highlighting for its Scheme
  375. ;; snippets. Install the result to #$output.
  376. (format (current-error-port) "processing ~a...~%" file)
  377. (let* ((shtml (call-with-input-file file html->shtml))
  378. (highlighted (syntax-highlight shtml anchors))
  379. (base (string-drop file (string-length #$input)))
  380. (target (string-append #$output base)))
  381. (mkdir-p (dirname target))
  382. (call-with-output-file target
  383. (lambda (port)
  384. (write-shtml-as-html highlighted port)))))
  385. (define (copy-as-is file)
  386. ;; Copy FILE as is to #$output.
  387. (let* ((base (string-drop file (string-length #$input)))
  388. (target (string-append #$output base)))
  389. (mkdir-p (dirname target))
  390. (catch 'system-error
  391. (lambda ()
  392. (if (eq? 'symlink (stat:type (lstat file)))
  393. (symlink (readlink file) target)
  394. (link file target)))
  395. (lambda args
  396. (let ((errno (system-error-errno args)))
  397. (pk 'error-link file target (strerror errno))
  398. (primitive-exit 3))))))
  399. (define (html? file stat)
  400. (string-suffix? ".html" file))
  401. ;; Install a UTF-8 locale so we can process UTF-8 files.
  402. (setenv "GUIX_LOCPATH"
  403. #+(file-append glibc-utf8-locales "/lib/locale"))
  404. (setlocale LC_ALL "en_US.utf8")
  405. ;; First process the mono-node 'guix.html' files.
  406. (n-par-for-each (parallel-job-count)
  407. (lambda (mono)
  408. (let ((anchors (collect-anchors mono)))
  409. (process-html mono anchors)))
  410. (find-files
  411. #$input
  412. "^guix(-cookbook|)(\\.[a-zA-Z_-]+)?\\.html$"))
  413. ;; Next process the multi-node HTML files in two phases: (1)
  414. ;; collect the list of anchors, and (2) perform
  415. ;; syntax-highlighting.
  416. (let* ((multi (find-files #$input "^html_node$"
  417. #:directories? #t))
  418. (anchors (n-par-map (parallel-job-count)
  419. (lambda (multi)
  420. (cons multi
  421. (fold collect-anchors vlist-null
  422. (find-files multi html?))))
  423. multi)))
  424. (n-par-for-each (parallel-job-count)
  425. (lambda (file)
  426. (let ((anchors (assoc-ref anchors (dirname file))))
  427. (process-html file anchors)))
  428. (append-map (lambda (multi)
  429. (find-files multi html?))
  430. multi)))
  431. ;; Last, copy non-HTML files as is.
  432. (for-each copy-as-is
  433. (find-files #$input (negate html?)))))))
  434. (computed-file name build))
  435. (define* (html-manual source #:key (languages %languages)
  436. (version "0.0")
  437. (manual %manual)
  438. (date 1)
  439. (options %makeinfo-html-options))
  440. "Return the HTML manuals built from SOURCE for all LANGUAGES, with the given
  441. makeinfo OPTIONS."
  442. (define manual-source
  443. (texinfo-manual-source source
  444. #:version version
  445. #:languages languages
  446. #:date date))
  447. (define images
  448. (texinfo-manual-images source))
  449. (define build
  450. (with-imported-modules '((guix build utils))
  451. #~(begin
  452. (use-modules (guix build utils)
  453. (ice-9 match))
  454. (define (normalize language)
  455. ;; Normalize LANGUAGE. For instance, "zh_CN" becomes "zh-cn".
  456. (string-map (match-lambda
  457. (#\_ #\-)
  458. (chr chr))
  459. (string-downcase language)))
  460. (define (language->texi-file-name language)
  461. (if (string=? language "en")
  462. (string-append #$manual-source "/"
  463. #$manual ".texi")
  464. (string-append #$manual-source "/"
  465. #$manual "." language ".texi")))
  466. ;; Install a UTF-8 locale so that 'makeinfo' is at ease.
  467. (setenv "GUIX_LOCPATH"
  468. #+(file-append glibc-utf8-locales "/lib/locale"))
  469. (setenv "LC_ALL" "en_US.utf8")
  470. (setvbuf (current-output-port) 'line)
  471. (setvbuf (current-error-port) 'line)
  472. ;; 'makeinfo' looks for "htmlxref.cnf" in the current directory, so
  473. ;; copy it right here.
  474. (copy-file (string-append #$manual-source "/htmlxref.cnf")
  475. "htmlxref.cnf")
  476. (for-each (lambda (language)
  477. (let* ((texi (language->texi-file-name language))
  478. (opts `("--html"
  479. "-c" ,(string-append "TOP_NODE_UP_URL=/manual/"
  480. language)
  481. #$@options
  482. ,texi)))
  483. (format #t "building HTML manual for language '~a'...~%"
  484. language)
  485. (mkdir-p (string-append #$output "/"
  486. (normalize language)))
  487. (setenv "LANGUAGE" language)
  488. (apply invoke #$(file-append texinfo "/bin/makeinfo")
  489. "-o" (string-append #$output "/"
  490. (normalize language)
  491. "/html_node")
  492. opts)
  493. (apply invoke #$(file-append texinfo "/bin/makeinfo")
  494. "--no-split"
  495. "-o"
  496. (string-append #$output "/"
  497. (normalize language)
  498. "/" #$manual
  499. (if (string=? language "en")
  500. ""
  501. (string-append "." language))
  502. ".html")
  503. opts)
  504. ;; Make sure images are available.
  505. (symlink #$images
  506. (string-append #$output "/" (normalize language)
  507. "/images"))
  508. (symlink #$images
  509. (string-append #$output "/" (normalize language)
  510. "/html_node/images"))))
  511. (filter (compose file-exists? language->texi-file-name)
  512. '#$languages)))))
  513. (let* ((name (string-append manual "-html-manual"))
  514. (manual (computed-file name build)))
  515. (syntax-highlighted-html manual
  516. #:name (string-append name "-highlighted"))))
  517. (define* (pdf-manual source #:key (languages %languages)
  518. (version "0.0")
  519. (manual %manual)
  520. (date 1)
  521. (options '()))
  522. "Return the HTML manuals built from SOURCE for all LANGUAGES, with the given
  523. makeinfo OPTIONS."
  524. (define manual-source
  525. (texinfo-manual-source source
  526. #:version version
  527. #:languages languages
  528. #:date date))
  529. ;; FIXME: This union works, except for the table of contents of non-English
  530. ;; manuals, which contains escape sequences like "^^ca^^fe" instead of
  531. ;; accented letters.
  532. ;;
  533. ;; (define texlive
  534. ;; (texlive-union (list texlive-tex-texinfo
  535. ;; texlive-generic-epsf
  536. ;; texlive-fonts-ec)))
  537. (define build
  538. (with-imported-modules '((guix build utils))
  539. #~(begin
  540. (use-modules (guix build utils)
  541. (srfi srfi-34)
  542. (ice-9 match))
  543. (define (normalize language) ;XXX: deduplicate
  544. ;; Normalize LANGUAGE. For instance, "zh_CN" becomes "zh-cn".
  545. (string-map (match-lambda
  546. (#\_ #\-)
  547. (chr chr))
  548. (string-downcase language)))
  549. ;; Install a UTF-8 locale so that 'makeinfo' is at ease.
  550. (setenv "GUIX_LOCPATH"
  551. #+(file-append glibc-utf8-locales "/lib/locale"))
  552. (setenv "LC_ALL" "en_US.utf8")
  553. (setenv "PATH"
  554. (string-append #+(file-append texlive "/bin") ":"
  555. #+(file-append texinfo "/bin") ":"
  556. ;; Below are command-line tools needed by
  557. ;; 'texi2dvi' and friends.
  558. #+(file-append sed "/bin") ":"
  559. #+(file-append grep "/bin") ":"
  560. #+(file-append coreutils "/bin") ":"
  561. #+(file-append gawk "/bin") ":"
  562. #+(file-append tar "/bin") ":"
  563. #+(file-append diffutils "/bin")))
  564. (setvbuf (current-output-port) 'line)
  565. (setvbuf (current-error-port) 'line)
  566. (setenv "HOME" (getcwd)) ;for kpathsea/mktextfm
  567. ;; 'SOURCE_DATE_EPOCH' is honored by pdftex.
  568. (setenv "SOURCE_DATE_EPOCH" "1")
  569. (for-each (lambda (language)
  570. (let ((opts `("--pdf"
  571. "-I" "."
  572. #$@options
  573. ,(if (string=? language "en")
  574. (string-append #$manual-source "/"
  575. #$manual ".texi")
  576. (string-append #$manual-source "/"
  577. #$manual "." language ".texi")))))
  578. (format #t "building PDF manual for language '~a'...~%"
  579. language)
  580. (mkdir-p (string-append #$output "/"
  581. (normalize language)))
  582. (setenv "LANGUAGE" language)
  583. ;; FIXME: Unfortunately building PDFs for non-Latin
  584. ;; alphabets doesn't work:
  585. ;; <https://lists.gnu.org/archive/html/help-texinfo/2012-01/msg00014.html>.
  586. (guard (c ((invoke-error? c)
  587. (format (current-error-port)
  588. "~%~%Failed to produce \
  589. PDF for language '~a'!~%~%"
  590. language)))
  591. (apply invoke #$(file-append texinfo "/bin/makeinfo")
  592. "--pdf" "-o"
  593. (string-append #$output "/"
  594. (normalize language)
  595. "/" #$manual
  596. (if (string=? language "en")
  597. ""
  598. (string-append "."
  599. language))
  600. ".pdf")
  601. opts))))
  602. '#$languages))))
  603. (computed-file (string-append manual "-pdf-manual") build))
  604. (define (guix-manual-text-domain source languages)
  605. "Return the PO files for LANGUAGES of the 'guix-manual' text domain taken
  606. from SOURCE."
  607. (define po-directory
  608. (file-append* source "/po/doc"))
  609. (define build
  610. (with-imported-modules '((guix build utils))
  611. #~(begin
  612. (use-modules (guix build utils))
  613. (mkdir-p #$output)
  614. (for-each (lambda (language)
  615. (define directory
  616. (string-append #$output "/" language
  617. "/LC_MESSAGES"))
  618. (mkdir-p directory)
  619. (invoke #+(file-append gnu-gettext "/bin/msgfmt")
  620. "-c" "-o"
  621. (string-append directory "/guix-manual.mo")
  622. (string-append #$po-directory "/guix-manual."
  623. language ".po")))
  624. '#$(delete "en" languages)))))
  625. (computed-file "guix-manual-po" build))
  626. (define* (html-manual-indexes source
  627. #:key (languages %languages)
  628. (version "0.0")
  629. (manual %manual)
  630. (title (if (string=? "guix" manual)
  631. "GNU Guix Reference Manual"
  632. "GNU Guix Cookbook"))
  633. (date 1))
  634. (define build
  635. (with-extensions (list guile-json-3)
  636. (with-imported-modules '((guix build utils))
  637. #~(begin
  638. (use-modules (guix build utils)
  639. (json)
  640. (ice-9 match)
  641. (ice-9 popen)
  642. (sxml simple)
  643. (srfi srfi-1)
  644. (srfi srfi-19))
  645. (define (normalize language) ;XXX: deduplicate
  646. ;; Normalize LANGUAGE. For instance, "zh_CN" becomes "zh-cn".
  647. (string-map (match-lambda
  648. (#\_ #\-)
  649. (chr chr))
  650. (string-downcase language)))
  651. (define-syntax-rule (with-language language exp ...)
  652. (let ((lang (getenv "LANGUAGE")))
  653. (dynamic-wind
  654. (lambda ()
  655. (setenv "LANGUAGE" language)
  656. (setlocale LC_MESSAGES))
  657. (lambda () exp ...)
  658. (lambda ()
  659. (if lang
  660. (setenv "LANGUAGE" lang)
  661. (unsetenv "LANGUAGE"))
  662. (setlocale LC_MESSAGES)))))
  663. ;; (put 'with-language 'scheme-indent-function 1)
  664. (define* (translate str language
  665. #:key (domain "guix-manual"))
  666. (define exp
  667. `(begin
  668. (bindtextdomain "guix-manual"
  669. #+(guix-manual-text-domain
  670. source
  671. languages))
  672. (bindtextdomain "iso_639-3" ;language names
  673. #+(file-append iso-codes
  674. "/share/locale"))
  675. (write (gettext ,str ,domain))))
  676. (with-language language
  677. ;; Since the 'gettext' function caches msgid translations,
  678. ;; regardless of $LANGUAGE, we have to spawn a new process each
  679. ;; time we want to translate to a different language. Bah!
  680. (let* ((pipe (open-pipe* OPEN_READ
  681. #+(file-append guile-2.2
  682. "/bin/guile")
  683. "-c" (object->string exp)))
  684. (str (read pipe)))
  685. (close-pipe pipe)
  686. str)))
  687. (define (seconds->string seconds language)
  688. (let* ((time (make-time time-utc 0 seconds))
  689. (date (time-utc->date time)))
  690. (with-language language (date->string date "~e ~B ~Y"))))
  691. (define (guix-url path)
  692. (string-append #$%web-site-url path))
  693. (define (sxml-index language title body)
  694. ;; FIXME: Avoid duplicating styling info from guix-artwork.git.
  695. `(html (@ (lang ,language))
  696. (head
  697. (title ,(string-append title " — GNU Guix"))
  698. (meta (@ (charset "UTF-8")))
  699. (meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
  700. ;; Menu prefetch.
  701. (link (@ (rel "prefetch") (href ,(guix-url "menu/index.html"))))
  702. ;; Base CSS.
  703. (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/elements.css"))))
  704. (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/common.css"))))
  705. (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/messages.css"))))
  706. (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/navbar.css"))))
  707. (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/breadcrumbs.css"))))
  708. (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/buttons.css"))))
  709. (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/footer.css"))))
  710. (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/page.css"))))
  711. (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/post.css")))))
  712. (body
  713. (header (@ (class "navbar"))
  714. (h1 (a (@ (class "branding")
  715. (href #$%web-site-url)))
  716. (span (@ (class "a11y-offset"))
  717. "Guix"))
  718. (nav (@ (class "menu"))))
  719. (nav (@ (class "breadcrumbs"))
  720. (a (@ (class "crumb")
  721. (href #$%web-site-url))
  722. "Home"))
  723. ,body
  724. (footer))))
  725. (define (language-index language)
  726. (define title
  727. (translate #$title language))
  728. (sxml-index
  729. language title
  730. `(main
  731. (article
  732. (@ (class "page centered-block limit-width"))
  733. (h2 ,title)
  734. (p (@ (class "post-metadata centered-text"))
  735. #$version " — "
  736. ,(seconds->string #$date language))
  737. (div
  738. (ul
  739. (li (a (@ (href "html_node"))
  740. "HTML, with one page per node"))
  741. (li (a (@ (href
  742. ,(string-append
  743. #$manual
  744. (if (string=? language
  745. "en")
  746. ""
  747. (string-append "."
  748. language))
  749. ".html")))
  750. "HTML, entirely on one page"))
  751. ,@(if (member language '("ru" "zh_CN"))
  752. '()
  753. `((li (a (@ (href ,(string-append
  754. #$manual
  755. (if (string=? language "en")
  756. ""
  757. (string-append "."
  758. language))
  759. ".pdf"))))
  760. "PDF")))))))))
  761. (define %iso639-languages
  762. (vector->list
  763. (assoc-ref (call-with-input-file
  764. #+(file-append iso-codes
  765. "/share/iso-codes/json/iso_639-3.json")
  766. json->scm)
  767. "639-3")))
  768. (define (language-code->name code)
  769. "Return the full name of a language from its ISO-639-3 code."
  770. (let ((code (match (string-index code #\_)
  771. (#f code)
  772. (index (string-take code index)))))
  773. (any (lambda (language)
  774. (and (string=? (or (assoc-ref language "alpha_2")
  775. (assoc-ref language "alpha_3"))
  776. code)
  777. (assoc-ref language "name")))
  778. %iso639-languages)))
  779. (define (top-level-index languages)
  780. (define title #$title)
  781. (sxml-index
  782. "en" title
  783. `(main
  784. (article
  785. (@ (class "page centered-block limit-width"))
  786. (h2 ,title)
  787. (div
  788. "This document is available in the following
  789. languages:\n"
  790. (ul
  791. ,@(map (lambda (language)
  792. `(li (a (@ (href ,(normalize language)))
  793. ,(translate
  794. (language-code->name language)
  795. language
  796. #:domain "iso_639-3"))))
  797. languages)))))))
  798. (define (write-html file sxml)
  799. (call-with-output-file file
  800. (lambda (port)
  801. (display "<!DOCTYPE html>\n" port)
  802. (sxml->xml sxml port))))
  803. (setenv "GUIX_LOCPATH"
  804. #+(file-append glibc-utf8-locales "/lib/locale"))
  805. (setenv "LC_ALL" "en_US.utf8")
  806. (setlocale LC_ALL "en_US.utf8")
  807. (for-each (lambda (language)
  808. (define directory
  809. (string-append #$output "/"
  810. (normalize language)))
  811. (mkdir-p directory)
  812. (write-html (string-append directory "/index.html")
  813. (language-index language)))
  814. '#$languages)
  815. (write-html (string-append #$output "/index.html")
  816. (top-level-index '#$languages))))))
  817. (computed-file "html-indexes" build))
  818. (define* (pdf+html-manual source
  819. #:key (languages %languages)
  820. (version "0.0")
  821. (date (time-second (current-time time-utc)))
  822. (manual %manual))
  823. "Return the union of the HTML and PDF manuals, as well as the indexes."
  824. (directory-union (string-append manual "-manual")
  825. (map (lambda (proc)
  826. (proc source
  827. #:date date
  828. #:languages languages
  829. #:version version
  830. #:manual manual))
  831. (list html-manual-indexes
  832. html-manual pdf-manual))
  833. #:copy? #t))
  834. (define (latest-commit+date directory)
  835. "Return two values: the last commit ID (a hex string) for DIRECTORY, and its
  836. commit date (an integer)."
  837. (let* ((repository (repository-open directory))
  838. (head (repository-head repository))
  839. (oid (reference-target head))
  840. (commit (commit-lookup repository oid)))
  841. ;; TODO: Use (git describe) when it's widely available.
  842. (values (oid->string oid) (commit-time commit))))
  843. (let* ((root (canonicalize-path
  844. (string-append (current-source-directory) "/..")))
  845. (commit date (latest-commit+date root)))
  846. (format (current-error-port)
  847. "building manual from work tree around commit ~a, ~a~%"
  848. commit
  849. (let* ((time (make-time time-utc 0 date))
  850. (date (time-utc->date time)))
  851. (date->string date "~e ~B ~Y")))
  852. (pdf+html-manual (local-file root "guix" #:recursive? #t
  853. #:select? (git-predicate root))
  854. #:version (or (getenv "GUIX_MANUAL_VERSION")
  855. (string-take commit 7))
  856. #:date date))