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.
 
 
 
 
 
 

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