build.scm 62 KB

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