X-Git-Url: http://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/f37789a523d3e4169b72312c3540b7624415c116..65ce5fe2fb1783c5eae7b439f79627fdb5e9c578:/doc/build.scm diff --git a/doc/build.scm b/doc/build.scm index c3d61f837b..7d0db8621f 100644 --- a/doc/build.scm +++ b/doc/build.scm @@ -1,5 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019, 2020 Ludovic Courtès +;;; Copyright © 2019-2022 Ludovic Courtès +;;; Copyright © 2020 Björn Höfling +;;; Copyright © 2022 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,9 +31,11 @@ (guix gexp) (guix git) (guix git-download) + (guix profiles) (guix utils) (git) (gnu packages base) + (gnu packages compression) (gnu packages gawk) (gnu packages gettext) (gnu packages guile) @@ -39,7 +43,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* @@ -57,9 +64,20 @@ (or (getenv "GUIX_MANUAL") "guix")) -(define %languages +(define %manual-languages + ;; Available translations for the 'guix-manual' text domain. '("de" "en" "es" "fr" "ru" "zh_CN")) +(define %cookbook-languages + ;; Available translations for the 'guix-cookbook' text domain. + '("de" "en" "fr" "sk")) + +(define %languages + ;; Available translations for the document being built. + (if (string=? %manual "guix-cookbook") + %cookbook-languages + %manual-languages)) + (define (texinfo-manual-images source) "Return a directory containing all the images used by the user manual, taken from SOURCE, the root of the source tree." @@ -137,12 +155,12 @@ as well as images, OS examples, and translations." (date->string date "~B ~Y") version version)))))) - (install-file #$(file-append* documentation "/htmlxref.cnf") + (install-file #$(file-append documentation "/htmlxref.cnf") #$output) (for-each (lambda (texi) (install-file texi #$output)) - (append (find-files #$documentation "\\.(texi|scm)$") + (append (find-files #$documentation "\\.(texi|scm|json)$") (find-files #$(translated-texi-manuals source) "\\.texi$"))) @@ -174,45 +192,182 @@ as well as images, OS examples, and translations." "-c" "EXTRA_HEAD=")) -(define guile-lib/htmlprag-fixed - ;; Guile-Lib with a hotfix for (htmlprag). - (package - (inherit guile-lib) - (source (origin - (inherit (package-source guile-lib)) - (modules '(( guix build utils))) - (snippet - '(begin - ;; When parsing - ;; "

foo

\n
", - ;; 'html->shtml' would mistakenly close 'blockquote' right - ;; before

. This patch removes 'p' from the - ;; 'parent-constraints' alist to fix that. - (substitute* "src/htmlprag.scm" - (("^[[:blank:]]*\\(p[[:blank:]]+\\. \\(body td th\\)\\).*") - "")) - #t)))) - (arguments - (substitute-keyword-arguments (package-arguments guile-lib) - ((#:phases phases '%standard-phases) - `(modify-phases ,phases - (add-before 'check 'skip-known-failure - (lambda _ - ;; XXX: The above change causes one test failure among - ;; the htmlprag tests. - (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) + (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)) + + (%strict-tokenizer? #t) + + (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

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: x + ;; but not: + ;; cups-configuration parameter: … + (let loop ((lst lst)) + (match lst + (((? string-or-entity?) rest ...) + (loop rest)) + ((('strong _ ...) _ ...) + #t) + ((('span ('@ ('class "symbol-definition-category")) + (? string-or-entity?) ...) rest ...) + #t) + (x + #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 "/" <>) + (or (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 blocks (as produced by 'makeinfo --html')." (define build - (with-extensions (list guile-lib/htmlprag-fixed guile-syntax-highlight) + (with-extensions (list guile-lib guile-syntax-highlight) (with-imported-modules '((guix build utils)) #~(begin (use-modules (htmlprag) @@ -221,10 +376,13 @@ its 
 blocks (as produced by 'makeinfo --html')."
                          (syntax-highlight lexers)
                          (guix build utils)
                          (srfi srfi-1)
+                         (srfi srfi-26)
                          (ice-9 match)
                          (ice-9 threads)
                          (ice-9 vlist))
 
+            (%strict-tokenizer? #t)
+
             (define (pair-open/close lst)
               ;; Pair 'open' and 'close' tags produced by 'highlights' and
               ;; produce nested 'paren' tags instead.
@@ -292,6 +450,7 @@ its 
 blocks (as produced by 'makeinfo --html')."
                 ("rarr"   "→")
                 ("hellip" "…")
                 ("rsquo"  "’")
+                ("nbsp"   " ")
                 (e (pk 'unknown-entity e) (primitive-exit 2))))
 
             (define (concatenate-snippets pieces)
@@ -308,10 +467,25 @@ its 
 blocks (as produced by 'makeinfo --html')."
                    (loop rest (cons (entity->string entity) strings)))
                   ((('span _ lst ...) . rest)     ;for 
                    (loop (append lst rest) strings))
+                  ((('var name) . rest)           ;for @var{name} within @lisp
+                   (loop rest (cons name strings))) ;XXX: losing formatting
                   (something
                    (pk 'unsupported-code-snippet something)
                    (primitive-exit 1)))))
 
+            (define (highlight-definition id category symbol args)
+              ;; Produce stylable HTML for the given definition (an @deftp,
+              ;; @deffn, or similar).
+              `(dt (@ (id ,id) (class "symbol-definition"))
+                   (span (@ (class "symbol-definition-category"))
+                         ,@category)
+                   (span (@ (class "symbol-definition-prototype"))
+                         ,symbol " " ,@args)))
+
+            (define (space? obj)
+              (and (string? obj)
+                   (string-every char-set:whitespace obj)))
+
             (define (syntax-highlight sxml anchors)
               ;; Recurse over SXML and syntax-highlight code snippets.
               (let loop ((sxml sxml))
@@ -330,6 +504,15 @@ its 
 blocks (as produced by 'makeinfo --html')."
                              (highlight lex-scheme
                                         (concatenate-snippets code-snippet)))
                             anchors)))
+
+                  ;; Replace the ugly  used for @deffn etc., which
+                  ;; translate to 
, with more stylable markup.
+                  (('dt (@ ('id id)) category ... ('strong thing))
+                   (highlight-definition id category thing '()))
+                  (('dt (@ ('id id)) category ... ('strong thing)
+                        (? space?) ('em args ...))
+                   (highlight-definition id category thing args))
+
                   ((tag ('@ attributes ...) body ...)
                    `(,tag (@ ,@attributes) ,@(map loop body)))
                   ((tag body ...)
@@ -337,64 +520,6 @@ its 
 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.
-              (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 
 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)))
-
-              (let ((shtml (call-with-input-file file html->shtml)))
-                (let loop ((shtml shtml)
-                           (vhash vhash))
-                  (match shtml
-                    ;; Attempt to match:
-                    ;;  
Scheme Variable: x

-                    ;; but not:
-                    ;;  
cups-configuration parameter: …

-                    (('dt ('@ ('id id))
-                          (? string-or-entity?) ... ('strong _ ...) _ ...)
-                     (if (string-prefix? "index-" id)
-                         (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.
@@ -426,36 +551,59 @@ its 
 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(\\.[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
@@ -463,9 +611,180 @@ its 
 blocks (as produced by 'makeinfo --html')."
 
   (computed-file name build))
 
+(define* (stylized-html source input
+                        #:key
+                        (languages %languages)
+                        (manual %manual)
+                        (manual-css-url "/static/base/css/manual.css"))
+  "Process all the HTML files in INPUT; add them MANUAL-CSS-URL as a