From ae737b439a058091813ece216edd9efc60e46503 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Sat, 20 Feb 2021 08:41:13 +0100 Subject: make: Add target for manual post-processing. --- build-aux/post-process-manual.scm | 158 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 158 insertions(+) create mode 100644 build-aux/post-process-manual.scm (limited to 'build-aux') 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 +;;; Copyright © 2021 Ricardo Wurmus +;;; +;;; 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 . + +(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 +
 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 
+           (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  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 ...)
+           `(,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)))
-- 
cgit v1.2.3