From 1db7d327e7bec46782afd131871aa8f0f607d2bd Mon Sep 17 00:00:00 2001
From: Anthony Scemama <scemama@irsamc.ups-tlse.fr>
Date: Tue, 27 Oct 2020 17:24:44 +0100
Subject: [PATCH] Syntax coloring in html

---
 src/config.el     | 87 +++++++++++++++++++++++++++++++++++++++++++++++
 src/create_doc.sh |  4 +--
 2 files changed, 89 insertions(+), 2 deletions(-)
 create mode 100755 src/config.el

diff --git a/src/config.el b/src/config.el
new file mode 100755
index 0000000..9395d1d
--- /dev/null
+++ b/src/config.el
@@ -0,0 +1,87 @@
+(require 'org)
+(require 'font-lock)
+
+(require 'subr-x) ;; for `when-let'
+
+(unless (boundp 'maximal-integer)
+  (defconst maximal-integer (lsh -1 -1)
+    "Maximal integer value representable natively in emacs lisp."))
+
+(defun face-spec-default (spec)
+  "Get list containing at most the default entry of face SPEC.
+Return nil if SPEC has no default entry."
+  (let* ((first (car-safe spec))
+     (display (car-safe first)))
+    (when (eq display 'default)
+      (list (car-safe spec)))))
+
+(defun face-spec-min-color (display-atts)
+  "Get min-color entry of DISPLAY-ATTS pair from face spec."
+  (let* ((display (car-safe display-atts)))
+    (or (car-safe (cdr (assoc 'min-colors display)))
+    maximal-integer)))
+
+(defun face-spec-highest-color (spec)
+  "Search face SPEC for highest color.
+That means the DISPLAY entry of SPEC
+with class 'color and highest min-color value."
+  (let ((color-list (cl-remove-if-not
+             (lambda (display-atts)
+               (when-let ((display (car-safe display-atts))
+                  (class (and (listp display)
+                          (assoc 'class display)))
+                  (background (assoc 'background display)))
+             (and (member 'light (cdr background))
+                  (member 'color (cdr class)))))
+             spec)))
+    (cl-reduce (lambda (display-atts1 display-atts2)
+         (if (> (face-spec-min-color display-atts1)
+            (face-spec-min-color display-atts2))
+             display-atts1
+           display-atts2))
+           (cdr color-list)
+           :initial-value (car color-list))))
+
+(defun face-spec-t (spec)
+  "Search face SPEC for fall back."
+  (cl-find-if (lambda (display-atts)
+        (eq (car-safe display-atts) t))
+          spec))
+
+(defun my-face-attribute (face attribute &optional frame inherit)
+  "Get FACE ATTRIBUTE from `face-user-default-spec' and not from `face-attribute'."
+  (let* ((face-spec (face-user-default-spec face))
+     (display-attr (or (face-spec-highest-color face-spec)
+               (face-spec-t face-spec)))
+     (attr (cdr display-attr))
+     (val (or (plist-get attr attribute) (car-safe (cdr (assoc attribute attr))))))
+    ;; (message "attribute: %S" attribute) ;; for debugging
+    (when (and (null (eq attribute :inherit))
+           (null val))
+      (let ((inherited-face (my-face-attribute face :inherit)))
+    (when (and inherited-face
+           (null (eq inherited-face 'unspecified)))
+      (setq val (my-face-attribute inherited-face attribute)))))
+    ;; (message "face: %S attribute: %S display-attr: %S, val: %S" face attribute display-attr val) ;; for debugging
+    (or val 'unspecified)))
+
+(advice-add 'face-attribute :override #'my-face-attribute)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Debugging:
+(defmacro print-args-and-ret (fun)
+  "Prepare FUN for printing args and return value."
+  `(advice-add (quote ,fun) :around
+           (lambda (oldfun &rest args)
+         (let ((ret (apply oldfun args)))
+           (message ,(concat "Calling " (symbol-name fun) " with args %S returns %S.") args ret)
+           ret))
+           '((name "print-args-and-ret"))))
+
+; (print-args-and-ret htmlize-faces-in-buffer)
+; (print-args-and-ret htmlize-get-override-fstruct)
+; (print-args-and-ret htmlize-face-to-fstruct)
+; (print-args-and-ret htmlize-attrlist-to-fstruct)
+; (print-args-and-ret face-foreground)
+; (print-args-and-ret face-background)
+; (print-args-and-ret face-attribute)
diff --git a/src/create_doc.sh b/src/create_doc.sh
index eddf509..8b7b146 100755
--- a/src/create_doc.sh
+++ b/src/create_doc.sh
@@ -3,8 +3,8 @@
 # Tangle org files
 
 emacsclient -a "" \
-            --socket-name=org_to_code \
-            --eval "(require 'org)"
+            --socket-name=org_to_code  \
+            --eval "(load-file \"config.el\")"
 
 for INPUT in $@ ; do
     echo $INPUT