diff options
| -rw-r--r-- | .gitmodules | 3 | ||||
| m--------- | haunt/emacs-htmlize | 0 | ||||
| -rw-r--r-- | haunt/jakob/reader/org-mode.scm | 167 |
3 files changed, 119 insertions, 51 deletions
diff --git a/.gitmodules b/.gitmodules index c94555d..61814de 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,6 @@ [submodule "ext-srfi-197"] path = haunt/ext-srfi-197 url = https://github.com/ar-nelson/srfi-197 +[submodule "haunt/emacs-htmlize"] + path = haunt/emacs-htmlize + url = https://github.com/hniksic/emacs-htmlize diff --git a/haunt/emacs-htmlize b/haunt/emacs-htmlize new file mode 160000 +Subproject ed5e5b05fd260e8f161a488d56f10e7f6e01fb7 diff --git a/haunt/jakob/reader/org-mode.scm b/haunt/jakob/reader/org-mode.scm index 2faeef3..7f064f1 100644 --- a/haunt/jakob/reader/org-mode.scm +++ b/haunt/jakob/reader/org-mode.scm @@ -19,38 +19,62 @@ ;;; Reader for Org syntax which invokes `org-export' via the Emacs daemon for ;;; rendering and metadata extraction. ;;; +;;; The choice to leverage Emacs, rather than writing a parser in Guile, was +;;; made because it enabled us to leverage other Emacs facilities such as +;;; `font-lock' and `htmlize' for syntax highlighting. +;;; ;;; Code: (define-module (jakob reader org-mode) + #:use-module (haunt reader) #:use-module (ice-9 match) #:use-module (ice-9 popen) - #:use-module (ice-9 regex) #:use-module (ice-9 textual-ports) + #:use-module (jakob utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) - #:use-module (haunt reader) - #:use-module (ice-9 match) + #:use-module (srfi-197) #:use-module (sxml simple) - #:export (org-mode-reader)) + #:export (render-org-mode-file + extract-org-mode-metadata + org-mode-reader)) + +;; Directory to store cached artifacts in. +;; +;; Caching is disabled if this is `#f'. +(define %cache-directory + (make-parameter (if (getenv "HAUNT_ORG_READER_DISABLE_CACHE") + #f + (or (getenv "HAUNT_ORG_READER_CACHE_DIR") + "./.org-mode-reader-cache/")))) + +;; Additional Org-mode keywords to include in the extracted metadata. +(define %additional-keys + (make-parameter '("CROSSPOST" "SCRIPTS" "META-TAGS"))) -(define (rewrite-image-urls subtree) - (match subtree - (('img ('@ ('src src) attrs ...)) - (let* ((src (if (string-prefix? "./" src) - (substring src 2) - src)) - (src (string-append "/static/image/" src))) - `(img (@ (src ,src) ,@attrs)))) - ((elems ...) - (map rewrite-image-urls elems)) - (elem elem))) +;; Whether to use a running Emacs daemon to evaluate elisp forms. +(define %use-emacsclient + (make-parameter (getenv "HAUNT_ORG_READER_USE_EMACSCLIENT"))) (define (eval-in-emacs form) - "Evaluate FORM in the current Emacs (daemon) session and return the result" - (let* ((stringified (call-with-output-string (cut write form <>))) - (port (open-pipe* OPEN_READ "emacsclient" "-e" stringified)) + "Evaluate s-exp FORM in Emacs and return the result + +If `%use-emacsclient' is truthy, evaluate FORM in the current running Emacs +daemon. Assumes that FORM does not write to `standard-output'." + (let* (;; We need to explicitly request that Emacs write the result if using + ;; Emacs batch mode (which is how we evaluate forms without + ;; `emacsclient'.) + (form (if (not (%use-emacsclient)) + `(print ,form) + form)) + (stringified (call-with-output-string (cut write form <>))) + (port (if (%use-emacsclient) + (open-pipe* OPEN_READ "emacsclient" "-e" stringified) + (open-pipe* OPEN_READ "emacs" "--batch" "--eval" stringified))) (result (read port)) + ;; The symbol `nil' doesn't have the same semantics in Scheme, so we'll + ;; convert it to the empty list. (result (if (eqv? result 'nil) '() result))) @@ -59,10 +83,13 @@ (error "could not eval" form)))) (define (render-org-mode-file file-name) - (define output-port (mkstemp! (string-copy "/tmp/emacs-eval-XXXXXX"))) + "Export FILE-NAME as an HTML document string" + (define output-file-name (tmpnam)) (define result (eval-in-emacs `(save-excursion + (load-file "./emacs-htmlize/htmlize.el") + (setq org-html-htmlize-output-type 'css) (let ((enable-local-variables :all)) (set-buffer (find-file-noselect ,file-name))) (setq-local org-export-filter-latex-fragment-functions @@ -71,42 +98,80 @@ (let ((result (org-export-as 'html nil nil t))) (with-temp-buffer (insert result) - (write-region (point-min) (point-max) ,(port-filename output-port))))))) - (define parsed (call-with-input-file (port-filename output-port) get-string-all)) - (format #f "<html>~a</html>" parsed)) + (write-region (point-min) (point-max) ,output-file-name)))))) + (define parsed (call-with-input-file output-file-name get-string-all)) + (delete-file output-file-name) + ;; We wrap in a `div' because when we call `xml->sxml' later on in + ;; `read-org-mode-post-fresh', it is expecting a single element. + (format #f "<div>~a</div>" parsed)) + +(define (extract-org-mode-metadata-raw file-name) + (map (match-lambda + ((key value) `(,(string->symbol (string-downcase key)) . ,value))) + (eval-in-emacs + `(save-excursion + (let ((enable-local-variables :all)) + (set-buffer (find-file-noselect ,file-name))) + (org-collect-keywords ',(append '("TITLE" "DATE" "TAGS") + (%additional-keys))))))) + +(define (parse-metadata metadata-alist) + (chain metadata-alist + (assq-map! _ 'date (cut string->date <> "<~Y-~m-~d ~a ~H:~M>")) + (assq-map! _ 'tags (cut string-split <> #\space)))) + +;; This is the public-facing interface. Because dates aren't serializable with +;; `write', the internal interface has extraction and parsing broken out into +;; separate procedures. +(define (extract-org-mode-metadata file-name) + "Parse the metadata out of FILE-NAME as an alist" + (chain file-name + (extract-org-mode-metadata-raw _) + (parse-metadata _))) + +(define (metadata-file-name hash) + (string-append (%cache-directory) + file-name-separator-string + hash + "-metadata")) +(define (sxml-file-name hash) + (string-append (%cache-directory) + file-name-separator-string + hash + "-sxml")) -(define %default-additional-keys - '("CROSSPOST" "SCRIPTS" "META-TAGS")) +(define (read-org-mode-post-cached hash) + (values (parse-metadata (call-with-input-file (metadata-file-name hash) read)) + (call-with-input-file (sxml-file-name hash) read))) -(define* (extract-org-mode-metadata file-name - #:optional - (additional-keys %default-additional-keys)) - `(,@(map (match-lambda - (("DATE" date) `(date . ,(string->date date "<~Y-~m-~d ~a ~H:~M>")))) - (eval-in-emacs - `(save-excursion - (let ((enable-local-variables :all)) - (set-buffer (find-file-noselect ,file-name))) - (org-collect-keywords '("DATE"))))) - ,@(map (match-lambda - (("TAGS" tags) `(tags . ,(string-split tags #\space)))) - (eval-in-emacs - `(save-excursion - (let ((enable-local-variables :all)) - (set-buffer (find-file-noselect ,file-name))) - (org-collect-keywords '("TAGS"))))) - ,@(map (match-lambda - ((key value) `(,(string->symbol (string-downcase key)) . ,value))) - (eval-in-emacs - `(save-excursion - (let ((enable-local-variables :all)) - (set-buffer (find-file-noselect ,file-name))) - (org-collect-keywords ',(append '("TITLE") additional-keys))))))) +(define (read-org-mode-post-fresh hash file-name) + (let ((metadata (extract-org-mode-metadata-raw file-name)) + (sxml (match (call-with-input-string (render-org-mode-file file-name) xml->sxml) + (('*TOP* ('div sxml ...)) sxml)))) + (when (%cache-directory) + (call-with-output-file (metadata-file-name hash) (cut write metadata <>)) + (call-with-output-file (sxml-file-name hash) (cut write sxml <>))) + (values (parse-metadata metadata) sxml))) (define (read-org-mode-post file-name) - (values (extract-org-mode-metadata file-name) - (match (call-with-input-string (render-org-mode-file file-name) xml->sxml) - (('*TOP* ('html sxml ...)) (rewrite-image-urls sxml))))) + (define hash + (let* ((port (open-pipe* OPEN_READ "md5sum" file-name)) + (result (string-trim-both (get-string-all port)))) + (unless (eqv? 0 (status:exit-val (close-pipe port))) + (error "cannot hash file")) + (first (string-split result #\ )))) + (when (%cache-directory) + (cond ((and (file-exists? (%cache-directory)) + (not (eqv? 'directory (stat:type (stat (%cache-directory)))))) + (error "cache directory exists but is not a directory" + (%cache-directory))) + ((not (file-exists? (%cache-directory))) + (mkdir (%cache-directory))))) + (if (and (%cache-directory) + (file-exists? (metadata-file-name hash)) + (file-exists? (sxml-file-name hash))) + (read-org-mode-post-cached hash) + (read-org-mode-post-fresh hash file-name))) (define org-mode-reader (make-reader (make-file-extension-matcher "org") |