mirror of
https://codeberg.org/guix/guix.git
synced 2025-10-02 02:15:12 +00:00
doc: Move manual index creation to a separate derivation.
* doc/build.scm (normalize-language-code, html-manual-identifier-index): New procedures. (syntax-highlighted-html): Add #:mono-node-indexes and #:split-node-indexes. [build](underscore-decode, anchor-id->key, collect-anchors): Remove. (language+node-anchors, mono-node-anchors, multi-node-anchors): New variables. Use them.
This commit is contained in:
Ludovic Courtès
parent
3cd1a7ac51
commit
0f7d0743ed
1 changed files with 206 additions and 97 deletions
303
doc/build.scm
303
doc/build.scm
|
|
@ -40,6 +40,7 @@
|
||||||
(gnu packages iso-codes)
|
(gnu packages iso-codes)
|
||||||
(gnu packages texinfo)
|
(gnu packages texinfo)
|
||||||
(gnu packages tex)
|
(gnu packages tex)
|
||||||
|
(ice-9 match)
|
||||||
(srfi srfi-19)
|
(srfi srfi-19)
|
||||||
(srfi srfi-71))
|
(srfi srfi-71))
|
||||||
|
|
||||||
|
|
@ -204,9 +205,168 @@ content=\"width=device-width, initial-scale=1\" />"))
|
||||||
(setenv "XFAIL_TESTS" "htmlprag.scm")
|
(setenv "XFAIL_TESTS" "htmlprag.scm")
|
||||||
#t))))))))
|
#t))))))))
|
||||||
|
|
||||||
|
(define (normalize-language-code language) ;XXX: deduplicate
|
||||||
|
;; Normalize LANGUAGE. For instance, "zh_CN" becomes "zh-cn".
|
||||||
|
(string-map (match-lambda
|
||||||
|
(#\_ #\-)
|
||||||
|
(chr chr))
|
||||||
|
(string-downcase language)))
|
||||||
|
|
||||||
|
(define* (html-manual-identifier-index manual base-url
|
||||||
|
#:key
|
||||||
|
(name "html-manual-identifier-index"))
|
||||||
|
"Return an index of all the identifiers that appear in MANUAL, a
|
||||||
|
makeinfo-generated manual. The index is a file that contains an alist; each
|
||||||
|
key is an identifier and the associated value is the URL reference pointing to
|
||||||
|
that identifier. The URL is constructed by concatenating BASE-URL to the
|
||||||
|
actual file name."
|
||||||
|
(define build
|
||||||
|
(with-extensions (list guile-lib/htmlprag-fixed)
|
||||||
|
(with-imported-modules '((guix build utils))
|
||||||
|
#~(begin
|
||||||
|
(use-modules (guix build utils)
|
||||||
|
(htmlprag)
|
||||||
|
(srfi srfi-1)
|
||||||
|
(srfi srfi-26)
|
||||||
|
(ice-9 ftw)
|
||||||
|
(ice-9 match)
|
||||||
|
(ice-9 threads)
|
||||||
|
(ice-9 pretty-print))
|
||||||
|
|
||||||
|
(define file-url
|
||||||
|
(let ((prefix (string-append #$manual "/")))
|
||||||
|
(lambda (file)
|
||||||
|
;; Return the URL for FILE.
|
||||||
|
(let ((file (string-drop file (string-length prefix)))
|
||||||
|
(base #$base-url))
|
||||||
|
(if (string-null? base)
|
||||||
|
file
|
||||||
|
(string-append base "/" file))))))
|
||||||
|
|
||||||
|
(define (underscore-decode str)
|
||||||
|
;; Decode STR, an "underscore-encoded" string as produced by
|
||||||
|
;; makeinfo for indexes, such as "_0025base_002dservices" for
|
||||||
|
;; "%base-services".
|
||||||
|
(let loop ((str str)
|
||||||
|
(result '()))
|
||||||
|
(match (string-index str #\_)
|
||||||
|
(#f
|
||||||
|
(string-concatenate-reverse (cons str result)))
|
||||||
|
(index
|
||||||
|
(let ((char (string->number
|
||||||
|
(substring str (+ index 1) (+ index 5))
|
||||||
|
16)))
|
||||||
|
(loop (string-drop str (+ index 5))
|
||||||
|
(append (list (string (integer->char char))
|
||||||
|
(string-take str index))
|
||||||
|
result)))))))
|
||||||
|
|
||||||
|
(define (anchor-id->key id)
|
||||||
|
;; Convert ID, an anchor ID such as
|
||||||
|
;; "index-pam_002dlimits_002dservice" to the corresponding key,
|
||||||
|
;; "pam-limits-service" in this example. Drop the suffix of
|
||||||
|
;; duplicate anchor IDs like "operating_002dsystem-1".
|
||||||
|
(let ((id (if (any (cut string-suffix? <> id)
|
||||||
|
'("-1" "-2" "-3" "-4" "-5"))
|
||||||
|
(string-drop-right id 2)
|
||||||
|
id)))
|
||||||
|
(underscore-decode
|
||||||
|
(string-drop id (string-length "index-")))))
|
||||||
|
|
||||||
|
(define* (collect-anchors file #:optional (anchors '()))
|
||||||
|
;; Collect the anchors that appear in FILE, a makeinfo-generated
|
||||||
|
;; file. Grab those from <dt> tags, which corresponds to
|
||||||
|
;; Texinfo @deftp, @defvr, etc. Return ANCHORS augmented with
|
||||||
|
;; more name/reference pairs.
|
||||||
|
(define string-or-entity?
|
||||||
|
(match-lambda
|
||||||
|
((? string?) #t)
|
||||||
|
(('*ENTITY* _ ...) #t)
|
||||||
|
(_ #f)))
|
||||||
|
|
||||||
|
(define (worthy-entry? lst)
|
||||||
|
;; Attempt to match:
|
||||||
|
;; Scheme Variable: <strong>x</strong>
|
||||||
|
;; but not:
|
||||||
|
;; <code>cups-configuration</code> parameter: …
|
||||||
|
(let loop ((lst lst))
|
||||||
|
(match lst
|
||||||
|
(((? string-or-entity?) rest ...)
|
||||||
|
(loop rest))
|
||||||
|
((('strong _ ...) _ ...)
|
||||||
|
#t)
|
||||||
|
(_ #f))))
|
||||||
|
|
||||||
|
(let ((shtml (call-with-input-file file html->shtml)))
|
||||||
|
(let loop ((shtml shtml)
|
||||||
|
(anchors anchors))
|
||||||
|
(match shtml
|
||||||
|
(('dt ('@ ('id id)) rest ...)
|
||||||
|
(if (and (string-prefix? "index-" id)
|
||||||
|
(worthy-entry? rest))
|
||||||
|
(alist-cons (anchor-id->key id)
|
||||||
|
(string-append (file-url file)
|
||||||
|
"#" id)
|
||||||
|
anchors)
|
||||||
|
anchors))
|
||||||
|
((tag ('@ _ ...) body ...)
|
||||||
|
(fold loop anchors body))
|
||||||
|
((tag body ...)
|
||||||
|
(fold loop anchors body))
|
||||||
|
(_ anchors)))))
|
||||||
|
|
||||||
|
(define (html-files directory)
|
||||||
|
;; Return the list of HTML files under DIRECTORY.
|
||||||
|
(map (cut string-append directory "/" <>)
|
||||||
|
(scandir #$manual (lambda (file)
|
||||||
|
(string-suffix? ".html" file)))))
|
||||||
|
|
||||||
|
(define anchors
|
||||||
|
(sort (concatenate
|
||||||
|
(n-par-map (parallel-job-count)
|
||||||
|
(cut collect-anchors <>)
|
||||||
|
(html-files #$manual)))
|
||||||
|
(match-lambda*
|
||||||
|
(((key1 . url1) (key2 . url2))
|
||||||
|
(if (string=? key1 key2)
|
||||||
|
(string<? url1 url2)
|
||||||
|
(string<? key1 key2))))))
|
||||||
|
|
||||||
|
(call-with-output-file #$output
|
||||||
|
(lambda (port)
|
||||||
|
(display ";; Identifier index for the manual.\n\n"
|
||||||
|
port)
|
||||||
|
(pretty-print anchors port)))))))
|
||||||
|
|
||||||
|
(computed-file name build))
|
||||||
|
|
||||||
|
(define* (html-identifier-indexes manual directory-suffix
|
||||||
|
#:key (languages %languages)
|
||||||
|
(manual-name %manual)
|
||||||
|
(base-url (const "")))
|
||||||
|
(map (lambda (language)
|
||||||
|
(let ((language (normalize-language-code language)))
|
||||||
|
(list language
|
||||||
|
(html-manual-identifier-index
|
||||||
|
(file-append manual "/" language directory-suffix)
|
||||||
|
(base-url language)
|
||||||
|
#:name (string-append manual-name "-html-index-"
|
||||||
|
language)))))
|
||||||
|
languages))
|
||||||
|
|
||||||
(define* (syntax-highlighted-html input
|
(define* (syntax-highlighted-html input
|
||||||
#:key
|
#:key
|
||||||
(name "highlighted-syntax")
|
(name "highlighted-syntax")
|
||||||
|
(languages %languages)
|
||||||
|
(mono-node-indexes
|
||||||
|
(html-identifier-indexes input ""
|
||||||
|
#:languages
|
||||||
|
languages))
|
||||||
|
(split-node-indexes
|
||||||
|
(html-identifier-indexes input
|
||||||
|
"/html_node"
|
||||||
|
#:languages
|
||||||
|
languages))
|
||||||
(syntax-css-url
|
(syntax-css-url
|
||||||
"/static/base/css/code.css"))
|
"/static/base/css/code.css"))
|
||||||
"Return a derivation called NAME that processes all the HTML files in INPUT
|
"Return a derivation called NAME that processes all the HTML files in INPUT
|
||||||
|
|
@ -341,78 +501,6 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
|
||||||
((? string? str)
|
((? string? str)
|
||||||
str))))
|
str))))
|
||||||
|
|
||||||
(define (underscore-decode str)
|
|
||||||
;; Decode STR, an "underscore-encoded" string as produced by
|
|
||||||
;; makeinfo for indexes, such as "_0025base_002dservices" for
|
|
||||||
;; "%base-services".
|
|
||||||
(let loop ((str str)
|
|
||||||
(result '()))
|
|
||||||
(match (string-index str #\_)
|
|
||||||
(#f
|
|
||||||
(string-concatenate-reverse (cons str result)))
|
|
||||||
(index
|
|
||||||
(let ((char (string->number
|
|
||||||
(substring str (+ index 1) (+ index 5))
|
|
||||||
16)))
|
|
||||||
(loop (string-drop str (+ index 5))
|
|
||||||
(append (list (string (integer->char char))
|
|
||||||
(string-take str index))
|
|
||||||
result)))))))
|
|
||||||
|
|
||||||
(define (anchor-id->key id)
|
|
||||||
;; Convert ID, an anchor ID such as
|
|
||||||
;; "index-pam_002dlimits_002dservice" to the corresponding key,
|
|
||||||
;; "pam-limits-service" in this example. Drop the suffix of
|
|
||||||
;; duplicate anchor IDs like "operating_002dsystem-1".
|
|
||||||
(let ((id (if (any (cut string-suffix? <> id)
|
|
||||||
'("-1" "-2" "-3" "-4" "-5"))
|
|
||||||
(string-drop-right id 2)
|
|
||||||
id)))
|
|
||||||
(underscore-decode
|
|
||||||
(string-drop id (string-length "index-")))))
|
|
||||||
|
|
||||||
(define* (collect-anchors file #:optional (vhash vlist-null))
|
|
||||||
;; Collect the anchors that appear in FILE, a makeinfo-generated
|
|
||||||
;; file. Grab those from <dt> tags, which corresponds to
|
|
||||||
;; Texinfo @deftp, @defvr, etc. Return VHASH augmented with
|
|
||||||
;; more name/reference pairs.
|
|
||||||
(define string-or-entity?
|
|
||||||
(match-lambda
|
|
||||||
((? string?) #t)
|
|
||||||
(('*ENTITY* _ ...) #t)
|
|
||||||
(_ #f)))
|
|
||||||
|
|
||||||
(define (worthy-entry? lst)
|
|
||||||
;; Attempt to match:
|
|
||||||
;; Scheme Variable: <strong>x</strong>
|
|
||||||
;; but not:
|
|
||||||
;; <code>cups-configuration</code> parameter: …
|
|
||||||
(let loop ((lst lst))
|
|
||||||
(match lst
|
|
||||||
(((? string-or-entity?) rest ...)
|
|
||||||
(loop rest))
|
|
||||||
((('strong _ ...) _ ...)
|
|
||||||
#t)
|
|
||||||
(_ #f))))
|
|
||||||
|
|
||||||
(let ((shtml (call-with-input-file file html->shtml)))
|
|
||||||
(let loop ((shtml shtml)
|
|
||||||
(vhash vhash))
|
|
||||||
(match shtml
|
|
||||||
(('dt ('@ ('id id)) rest ...)
|
|
||||||
(if (and (string-prefix? "index-" id)
|
|
||||||
(worthy-entry? rest))
|
|
||||||
(vhash-cons (anchor-id->key id)
|
|
||||||
(string-append (basename file)
|
|
||||||
"#" id)
|
|
||||||
vhash)
|
|
||||||
vhash))
|
|
||||||
((tag ('@ _ ...) body ...)
|
|
||||||
(fold loop vhash body))
|
|
||||||
((tag body ...)
|
|
||||||
(fold loop vhash body))
|
|
||||||
(_ vhash)))))
|
|
||||||
|
|
||||||
(define (process-html file anchors)
|
(define (process-html file anchors)
|
||||||
;; Parse FILE and perform syntax highlighting for its Scheme
|
;; Parse FILE and perform syntax highlighting for its Scheme
|
||||||
;; snippets. Install the result to #$output.
|
;; snippets. Install the result to #$output.
|
||||||
|
|
@ -444,38 +532,59 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
|
||||||
(define (html? file stat)
|
(define (html? file stat)
|
||||||
(string-suffix? ".html" file))
|
(string-suffix? ".html" file))
|
||||||
|
|
||||||
|
(define language+node-anchors
|
||||||
|
(match-lambda
|
||||||
|
((language files ...)
|
||||||
|
(cons language
|
||||||
|
(fold (lambda (file vhash)
|
||||||
|
(let ((alist (call-with-input-file file read)))
|
||||||
|
;; Use 'fold-right' so that the first entry
|
||||||
|
;; wins (e.g., "car" from "Pairs" rather than
|
||||||
|
;; from "rnrs base" in the Guile manual).
|
||||||
|
(fold-right (match-lambda*
|
||||||
|
(((key . value) vhash)
|
||||||
|
(vhash-cons key value vhash)))
|
||||||
|
vhash
|
||||||
|
alist)))
|
||||||
|
vlist-null
|
||||||
|
files)))))
|
||||||
|
|
||||||
|
(define mono-node-anchors
|
||||||
|
;; List of language/vhash pairs, where each vhash maps an
|
||||||
|
;; identifier to the corresponding URL in a single-page manual.
|
||||||
|
(map language+node-anchors '#$mono-node-indexes))
|
||||||
|
|
||||||
|
(define multi-node-anchors
|
||||||
|
;; Likewise for split-node manuals.
|
||||||
|
(map language+node-anchors '#$split-node-indexes))
|
||||||
|
|
||||||
;; Install a UTF-8 locale so we can process UTF-8 files.
|
;; Install a UTF-8 locale so we can process UTF-8 files.
|
||||||
(setenv "GUIX_LOCPATH"
|
(setenv "GUIX_LOCPATH"
|
||||||
#+(file-append glibc-utf8-locales "/lib/locale"))
|
#+(file-append glibc-utf8-locales "/lib/locale"))
|
||||||
(setlocale LC_ALL "en_US.utf8")
|
(setlocale LC_ALL "en_US.utf8")
|
||||||
|
|
||||||
;; First process the mono-node 'guix.html' files.
|
;; First process the mono-node 'guix.html' files.
|
||||||
(n-par-for-each (parallel-job-count)
|
(for-each (match-lambda
|
||||||
(lambda (mono)
|
((language . anchors)
|
||||||
(let ((anchors (collect-anchors mono)))
|
(let ((files (find-files
|
||||||
(process-html mono anchors)))
|
(string-append #$input "/" language)
|
||||||
(find-files
|
"^guix(-cookbook|)(\\.[a-zA-Z_-]+)?\\.html$")))
|
||||||
#$input
|
(n-par-for-each (parallel-job-count)
|
||||||
"^guix(-cookbook|)(\\.[a-zA-Z_-]+)?\\.html$"))
|
(cut process-html <> anchors)
|
||||||
|
files))))
|
||||||
|
mono-node-anchors)
|
||||||
|
|
||||||
;; Next process the multi-node HTML files in two phases: (1)
|
;; Process the multi-node HTML files.
|
||||||
;; collect the list of anchors, and (2) perform
|
(for-each (match-lambda
|
||||||
;; syntax-highlighting.
|
((language . anchors)
|
||||||
(let* ((multi (find-files #$input "^html_node$"
|
(let ((files (find-files
|
||||||
#:directories? #t))
|
(string-append #$input "/" language
|
||||||
(anchors (n-par-map (parallel-job-count)
|
"/html_node")
|
||||||
(lambda (multi)
|
"\\.html$")))
|
||||||
(cons multi
|
(n-par-for-each (parallel-job-count)
|
||||||
(fold collect-anchors vlist-null
|
(cut process-html <> anchors)
|
||||||
(find-files multi html?))))
|
files))))
|
||||||
multi)))
|
multi-node-anchors)
|
||||||
(n-par-for-each (parallel-job-count)
|
|
||||||
(lambda (file)
|
|
||||||
(let ((anchors (assoc-ref anchors (dirname file))))
|
|
||||||
(process-html file anchors)))
|
|
||||||
(append-map (lambda (multi)
|
|
||||||
(find-files multi html?))
|
|
||||||
multi)))
|
|
||||||
|
|
||||||
;; Last, copy non-HTML files as is.
|
;; Last, copy non-HTML files as is.
|
||||||
(for-each copy-as-is
|
(for-each copy-as-is
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue