diff options
Diffstat (limited to 'doc/build.scm')
| -rw-r--r-- | doc/build.scm | 178 |
1 files changed, 145 insertions, 33 deletions
diff --git a/doc/build.scm b/doc/build.scm index 8d5b58962a..994b94eae2 100644 --- a/doc/build.scm +++ b/doc/build.scm @@ -220,8 +220,11 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')." (syntax-highlight scheme) (syntax-highlight lexers) (guix build utils) + (srfi srfi-1) + (srfi srfi-26) (ice-9 match) - (ice-9 threads)) + (ice-9 threads) + (ice-9 vlist)) (define (pair-open/close lst) ;; Pair 'open' and 'close' tags produced by 'highlights' and @@ -255,10 +258,11 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')." level (reverse result))) (values (reverse result) "" '()))))) - (define (highlights->sxml* highlights) + (define (highlights->sxml* highlights anchors) ;; Like 'highlights->sxml', but handle nested 'paren tags. This ;; allows for paren matching highlights via appropriate CSS - ;; "hover" properties. + ;; "hover" properties. When a symbol is encountered, look it up + ;; in ANCHORS, a vhash, and emit the corresponding href, if any. (define (tag->class tag) (string-append "syntax-" (symbol->string tag))) @@ -269,8 +273,16 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')." (number->string level)))) ,open (span (@ (class "syntax-symbol")) - ,@(highlights->sxml* body)) + ,@(highlights->sxml* body anchors)) ,close)) + (('symbol text) + ;; Check whether we can emit a hyperlink for TEXT. + (match (vhash-assoc text anchors) + (#f + `(span (@ (class ,(tag->class 'symbol))) ,text)) + ((_ . target) + `(a (@ (class ,(tag->class 'symbol)) (href ,target)) + ,text)))) ((tag text) `(span (@ (class ,(tag->class tag))) ,text))) highlights)) @@ -301,35 +313,109 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')." (pk 'unsupported-code-snippet something) (primitive-exit 1))))) - (define (syntax-highlight sxml) + (define (syntax-highlight sxml anchors) ;; Recurse over SXML and syntax-highlight code snippets. - (match sxml - (('*TOP* decl body ...) - `(*TOP* ,decl ,@(map syntax-highlight body))) - (('head things ...) - `(head ,@things - (link (@ (rel "stylesheet") - (type "text/css") - (href #$syntax-css-url))))) - (('pre ('@ ('class "lisp")) code-snippet ...) - `(pre (@ (class "lisp")) - ,@(highlights->sxml* - (pair-open/close - (highlight lex-scheme - (concatenate-snippets code-snippet)))))) - ((tag ('@ attributes ...) body ...) - `(,tag (@ ,@attributes) ,@(map syntax-highlight body))) - ((tag body ...) - `(,tag ,@(map syntax-highlight body))) - ((? string? str) - str))) - - (define (process-html file) + (let loop ((sxml sxml)) + (match sxml + (('*TOP* decl body ...) + `(*TOP* ,decl ,@(map loop body))) + (('head things ...) + `(head ,@things + (link (@ (rel "stylesheet") + (type "text/css") + (href #$syntax-css-url))))) + (('pre ('@ ('class "lisp")) code-snippet ...) + `(pre (@ (class "lisp")) + ,@(highlights->sxml* + (pair-open/close + (highlight lex-scheme + (concatenate-snippets code-snippet))) + anchors))) + ((tag ('@ attributes ...) body ...) + `(,tag (@ ,@attributes) ,@(map loop body))) + ((tag body ...) + `(,tag ,@(map loop body))) + ((? 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. (format (current-error-port) "processing ~a...~%" file) (let* ((shtml (call-with-input-file file html->shtml)) - (highlighted (syntax-highlight shtml)) + (highlighted (syntax-highlight shtml anchors)) (base (string-drop file (string-length #$input))) (target (string-append #$output base))) (mkdir-p (dirname target)) @@ -352,17 +438,43 @@ its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')." (pk 'error-link file target (strerror errno)) (primitive-exit 3)))))) + (define (html? file stat) + (string-suffix? ".html" file)) + ;; 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 (file) - (if (string-suffix? ".html" file) - (process-html file) - (copy-as-is file))) - (find-files #$input)))))) + (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))) + + ;; Last, copy non-HTML files as is. + (for-each copy-as-is + (find-files #$input (negate html?))))))) (computed-file name build)) |