diff options
Diffstat (limited to 'doc/build.scm')
| -rw-r--r-- | doc/build.scm | 457 |
1 files changed, 353 insertions, 104 deletions
diff --git a/doc/build.scm b/doc/build.scm index 97f4ab6b83..dac62493f4 100644 --- a/doc/build.scm +++ b/doc/build.scm @@ -33,6 +33,7 @@ (guix utils) (git) (gnu packages base) + (gnu packages compression) (gnu packages gawk) (gnu packages gettext) (gnu packages guile) @@ -40,7 +41,10 @@ (gnu packages iso-codes) (gnu packages texinfo) (gnu packages tex) + (ice-9 match) + (srfi srfi-1) (srfi srfi-19) + (srfi srfi-26) (srfi srfi-71)) (define file-append* @@ -204,9 +208,168 @@ content=\"width=device-width, initial-scale=1\" />")) (setenv "XFAIL_TESTS" "htmlprag.scm") #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 #:key (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 "/static/base/css/code.css")) "Return a derivation called NAME that processes all the HTML files in INPUT @@ -341,78 +504,6 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')." ((? string? 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) ;; Parse FILE and perform syntax highlighting for its Scheme ;; snippets. Install the result to #$output. @@ -444,38 +535,59 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')." (define (html? file stat) (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. (setenv "GUIX_LOCPATH" #+(file-append glibc-utf8-locales "/lib/locale")) (setlocale LC_ALL "en_US.utf8") ;; First process the mono-node 'guix.html' files. - (n-par-for-each (parallel-job-count) - (lambda (mono) - (let ((anchors (collect-anchors mono))) - (process-html mono anchors))) - (find-files - #$input - "^guix(-cookbook|)(\\.[a-zA-Z_-]+)?\\.html$")) - - ;; Next process the multi-node HTML files in two phases: (1) - ;; collect the list of anchors, and (2) perform - ;; syntax-highlighting. - (let* ((multi (find-files #$input "^html_node$" - #:directories? #t)) - (anchors (n-par-map (parallel-job-count) - (lambda (multi) - (cons multi - (fold collect-anchors vlist-null - (find-files multi html?)))) - multi))) - (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))) + (for-each (match-lambda + ((language . anchors) + (let ((files (find-files + (string-append #$input "/" language) + "^guix(-cookbook|)(\\.[a-zA-Z_-]+)?\\.html$"))) + (n-par-for-each (parallel-job-count) + (cut process-html <> anchors) + files)))) + mono-node-anchors) + + ;; Process the multi-node HTML files. + (for-each (match-lambda + ((language . anchors) + (let ((files (find-files + (string-append #$input "/" language + "/html_node") + "\\.html$"))) + (n-par-for-each (parallel-job-count) + (cut process-html <> anchors) + files)))) + multi-node-anchors) ;; Last, copy non-HTML files as is. (for-each copy-as-is @@ -486,6 +598,8 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')." (define* (html-manual source #:key (languages %languages) (version "0.0") (manual %manual) + (mono-node-indexes (map list languages)) + (split-node-indexes (map list languages)) (date 1) (options %makeinfo-html-options)) "Return the HTML manuals built from SOURCE for all LANGUAGES, with the given @@ -574,6 +688,8 @@ makeinfo OPTIONS." (let* ((name (string-append manual "-html-manual")) (manual (computed-file name build))) (syntax-highlighted-html manual + #:mono-node-indexes mono-node-indexes + #:split-node-indexes split-node-indexes #:name (string-append name "-highlighted")))) (define* (pdf-manual source #:key (languages %languages) @@ -920,6 +1036,8 @@ languages:\n" #:key (languages %languages) (version "0.0") (date (time-second (current-time time-utc))) + (mono-node-indexes (map list %languages)) + (split-node-indexes (map list %languages)) (manual %manual)) "Return the union of the HTML and PDF manuals, as well as the indexes." (directory-union (string-append manual "-manual") @@ -930,7 +1048,12 @@ languages:\n" #:version version #:manual manual)) (list html-manual-indexes - html-manual pdf-manual)) + (lambda (source . args) + (apply html-manual source + #:mono-node-indexes mono-node-indexes + #:split-node-indexes split-node-indexes + args)) + pdf-manual)) #:copy? #t)) (define (latest-commit+date directory) @@ -944,17 +1067,143 @@ commit date (an integer)." (values (oid->string oid) (commit-time commit)))) +;;; +;;; Guile manual. +;;; + +(define guile-manual + ;; The Guile manual as HTML, including both the mono-node "guile.html" and + ;; the split-node "html_node" directory. + (let ((guile guile-3.0-latest)) + (computed-file (string-append "guile-manual-" (package-version guile)) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (setenv "PATH" + (string-append #+tar "/bin:" + #+xz "/bin:" + #+texinfo "/bin")) + (invoke "tar" "xf" #$(package-source guile)) + (mkdir-p (string-append #$output "/en/html_node")) + + (let* ((texi (find-files "." "^guile\\.texi$")) + (documentation (match texi + ((file) (dirname file))))) + (with-directory-excursion documentation + (invoke "makeinfo" "--html" "--no-split" + "-o" (string-append #$output + "/en/guile.html") + "guile.texi") + (invoke "makeinfo" "--html" "-o" "split" + "guile.texi") + (copy-recursively + "split" + (string-append #$output "/en/html_node"))))))))) + +(define %guile-manual-base-url + "https://www.gnu.org/software/guile/manual") + +(define (for-all-languages index) + (map (lambda (language) + (list language index)) + %languages)) + +(define guile-mono-node-indexes + ;; The Guile manual is only available in English so use the same index in + ;; all languages. + (for-all-languages + (html-manual-identifier-index (file-append guile-manual "/en") + %guile-manual-base-url + #:name "guile-html-index-en"))) + +(define guile-split-node-indexes + (for-all-languages + (html-manual-identifier-index (file-append guile-manual "/en/html_node") + (string-append %guile-manual-base-url + "/html_node") + #:name "guile-html-index-en"))) + +(define (merge-index-alists alist1 alist2) + "Merge ALIST1 and ALIST2, both of which are list of tuples like: + + (LANGUAGE INDEX1 INDEX2 ...) + +where LANGUAGE is a string like \"en\" and INDEX1 etc. are indexes as returned +by 'html-identifier-indexes'." + (let ((languages (delete-duplicates + (append (match alist1 + (((languages . _) ...) + languages)) + (match alist2 + (((languages . _) ...) + languages)))))) + (map (lambda (language) + (cons language + (append (or (assoc-ref alist1 language) '()) + (or (assoc-ref alist2 language) '())))) + languages))) + + (let* ((root (canonicalize-path (string-append (current-source-directory) "/.."))) - (commit date (latest-commit+date root))) + (commit date (latest-commit+date root)) + (version (or (getenv "GUIX_MANUAL_VERSION") + (string-take commit 7))) + (select? (let ((vcs? (git-predicate root))) + (lambda (file stat) + (and (vcs? file stat) + ;; Filter out this file. + (not (string=? (basename file) "build.scm")))))) + (source (local-file root "guix" #:recursive? #t + #:select? select?))) + + (define guix-manual + (html-manual source + #:manual "guix" + #:version version + #:date date)) + + (define guix-mono-node-indexes + ;; Alist of indexes for GUIX-MANUAL, where each key is a language code and + ;; each value is a file-like object containing the identifier index. + (html-identifier-indexes guix-manual "" + #:manual-name "guix" + #:base-url (if (string=? %manual "guix") + (const "") + (cut string-append "/manual/" <>)) + #:languages %languages)) + + (define guix-split-node-indexes + ;; Likewise for the split-node variant of GUIX-MANUAL. + (html-identifier-indexes guix-manual "/html_node" + #:manual-name "guix" + #:base-url (if (string=? %manual "guix") + (const "") + (cut string-append "/manual/" <> + "/html_node")) + #:languages %languages)) + + (define mono-node-indexes + (merge-index-alists guix-mono-node-indexes guile-mono-node-indexes)) + + (define split-node-indexes + (merge-index-alists guix-split-node-indexes guile-split-node-indexes)) + (format (current-error-port) "building manual from work tree around commit ~a, ~a~%" commit (let* ((time (make-time time-utc 0 date)) (date (time-utc->date time))) (date->string date "~e ~B ~Y"))) - (pdf+html-manual (local-file root "guix" #:recursive? #t - #:select? (git-predicate root)) - #:version (or (getenv "GUIX_MANUAL_VERSION") - (string-take commit 7)) + + (pdf+html-manual source + ;; Always use the identifier indexes of GUIX-MANUAL and + ;; GUILE-MANUAL. Both "guix" and "guix-cookbook" can + ;; contain links to definitions that appear in either of + ;; these two manuals. + #:mono-node-indexes mono-node-indexes + #:split-node-indexes split-node-indexes + #:version version #:date date)) |