diff options
| -rw-r--r-- | Makefile.am | 12 | ||||
| -rw-r--r-- | build-aux/post-process-manual.scm | 158 |
2 files changed, 170 insertions, 0 deletions
diff --git a/Makefile.am b/Makefile.am index 5694a14..6610962 100644 --- a/Makefile.am +++ b/Makefile.am @@ -78,6 +78,18 @@ AM_MAKEINFOHTMLFLAGS = \ -c TOC_LINKS=true \ -c 'EXTRA_HEAD=<meta name="viewport" \ content="width=device-width, initial-scale=1" />' + +manual: $(abs_builddir)/doc/guile-picture-language.html + +$(abs_builddir)/doc/guile-picture-language.html: html + $(GUILE) --no-auto-compile -e main \ + $(top_srcdir)/build-aux/post-process-manual.scm \ + "$(abs_builddir)/doc/picture-language.html" "$(abs_builddir)/doc/guile-picture-language.html" + +upload-manual: manual + scp "$(abs_builddir)/doc/guile-picture-language.html" elephly.net:~/elephly.net/guile-picture-language/manual.html && \ + scp -r "$(abs_builddir)/doc/images" elephly.net:~/elephly.net/guile-picture-language/images + dist-hook: gen-ChangeLog gen-ChangeLog: $(AM_V_GEN)if test -d .git; then \ diff --git a/build-aux/post-process-manual.scm b/build-aux/post-process-manual.scm new file mode 100644 index 0000000..4f60d69 --- /dev/null +++ b/build-aux/post-process-manual.scm @@ -0,0 +1,158 @@ +;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; This file is part of the Guile Picture Language. +;;; Parts of it were taken from Guix and the Guix Workflow Language. +;;; +;;; This program is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +(use-modules (htmlprag) + (syntax-highlight) + (syntax-highlight scheme) + (syntax-highlight lexers) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match) + (ice-9 ftw)) + +;; Taken from (guix build utils) +(define (mkdir-p dir) + "Create directory DIR and all its ancestors." + (define absolute? + (string-prefix? "/" dir)) + + (define not-slash + (char-set-complement (char-set #\/))) + + (let loop ((components (string-tokenize dir not-slash)) + (root (if absolute? + "" + "."))) + (match components + ((head tail ...) + (let ((path (string-append root "/" head))) + (catch 'system-error + (lambda () + (mkdir path) + (loop tail path)) + (lambda args + (if (= EEXIST (system-error-errno args)) + (loop tail path) + (apply throw args)))))) + (() #t)))) + +(define (syntax-highlighted-html %input %output) + "Process all the HTML files in INPUT by highlighting the syntax of all its +<pre class=\"lisp\"> blocks (as produced by 'makeinfo --html'). Write +generated files to %output." + (begin + (define entity->string + (match-lambda + ("rArr" "⇒") + ("rarr" "→") + ("hellip" "…") + ("rsquo" "’") + (e (pk 'unknown-entity e) (primitive-exit 2)))) + + (define (concatenate-snippets pieces) + ;; Concatenate PIECES, which contains strings and entities, + ;; replacing entities with their corresponding string. + (let loop ((pieces pieces) + (strings '())) + (match pieces + (() + (string-concatenate-reverse strings)) + (((? string? str) . rest) + (loop rest (cons str strings))) + ((('*ENTITY* "additional" entity) . rest) + (loop rest (cons (entity->string entity) strings))) + ((('span _ lst ...) . rest) ;for <span class="roman"> + (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) + ;; Recurse over SXML and syntax-highlight code snippets. + (let loop ((sxml sxml)) + (match sxml + (('*TOP* decl body ...) + `(*TOP* ,decl ,@(map loop body))) + ((or ('div ('@ ('class "lisp")) + (? space?) ; annoying! + ('pre ('@ ('class (or "verbatim" "lisp"))) code-snippet ...)) + ('pre ('@ ('class "lisp")) code-snippet ...)) + (let ((code (concatenate-snippets code-snippet))) + `(pre (@ (class "lisp")) + (code (@ (class "scheme")) + ,@(highlights->sxml + (highlight lex-scheme code)))))) + + ;; Replace the ugly <strong> used for @deffn etc., which + ;; translate to <dt>, 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 ...) + `(,tag ,@(map loop body))) + ((? string? str) + str)))) + + (define (process-html file) + ;; 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)) + (base (string-drop file (string-length %input))) + (target (string-append %output base))) + (mkdir-p (dirname target)) + (call-with-output-file target + (lambda (port) + (write-shtml-as-html highlighted port))))) + + (define (html? file) + (string-suffix? ".html" file)) + + (ftw %input (lambda (filename statinfo flag) + (match flag + ('regular + (and (html? filename) + (process-html filename))) + (_ #t)) + #t)))) + +(define (main args) + (setlocale LC_ALL "en_US.utf8") + (apply syntax-highlighted-html (cdr args))) |