build.scm 62 KB

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