#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do htmlize-scheme)' -s $0 "$@" # -*-scheme-*-
!#
;;; htmlize-scheme

;; Copyright (C) 2005, 2007, 2008, 2009, 2010 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Commentary:

;; Usage: htmlize-scheme [options] FILE...
;;
;; Load htmlization-map files, process FILE, write FILE.html.
;; Options are:
;;  -l, --load HMAP    -- load htmlization map file HMAP
;;  -d, --hmap-dir DIR -- load all *.hmap files in DIR
;;      --css CSS      -- if CSS begins with a space character,
;;                        use it literally, otherwise, take it
;;                        as a filename and use its contents
;;      --elisp FILE   -- arrange for the inferior Emacs to
;;                        do `(load-file FILE)'
;;
;; In FILE.html, mappings specified in hmap files are substituted using
;; the hmap-specified stem and leaf.  At least one HMAP must be loaded.
;;
;; This program relies on htmlize.el, which does not always generate the
;; correct colors for the <style> block due to tricky (i.e., unresolved)
;; font-lock issues when used in batch mode.  As a kludge, you can use
;; `--css CSS' to completely replace that block with the contents of file
;; CSS (automatically wrapped with a <style> element).  As a special
;; case, if CSS begins with a space, it is taken to be the literal string.
;;
;; The htmlization-map file contains Scheme code define a mapping between
;; a piece of typed `html anchor' text and its url leaf.  At the moment,
;; the only supported type is #:module-name.  When TEXT is recognized,
;; it is replaced with: <a href="FULL">TEXT</a>, where FULL is formed by
;; concatenating the stem with the LEAF.
;;
;; To define a mapping, use the Scheme proc `define-mapping'.
;;
;; You can customize the default processing done by htmlize.el by
;; specifying `--elisp FILE', which is loaded where indicated in
;; the Emacs Lisp sequence:
;;
;;  (progn
;;    (setq vc-handled-backends nil)
;;    (require 'htmlize)
;;    (require 'scheme)
;;    ;;;
;;    ;;; maybe do (load-file FILE) here
;;    ;;;
;;    (pushnew '("." . scheme-mode) auto-mode-alist :test 'equal) ; yuk
;;    (let ((enable-local-variables nil)
;;          (enable-local-eval nil))
;;      (htmlize-many-files command-line-args-left)))

;;; Code:

(define-module (ttn-do htmlize-scheme)
  #:export (define-mapping
            main)
  #:use-module ((ice-9 and-let-star) #:select (and-let*))
  #:use-module ((ice-9 common-list) #:select (uniq))
  #:use-module ((ice-9 editing-buffer) #:select (find-file
                                                 filename:
                                                 editing-buffer))
  #:use-module ((ice-9 format) #:select (format))
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((ttn-do zzz filesystem) #:select (filtered-files
                                                  extract-stem-proc))
  #:use-module ((ttn-do zzz personally) #:select (accumulator
                                                  FE))
  #:use-module ((ttn-do zzz subprocess) #:select (call-process)))

(define (fs s . args)
  (apply format #f s args))

(define (make-html-files! more-elisp filenames)
  (call-process
   "emacs" #:inp #f #:outp #f #:errp #f #:args
   (list*
    "-batch" "--eval"
    (object->string
     `(progn
       (setq vc-handled-backends nil)
       (require 'htmlize)
       (require 'scheme)
       ,(if more-elisp `(load-file ,more-elisp) nil)
       (pushnew '("." . scheme-mode) auto-mode-alist :test 'equal) ; yuk
       (let ((enable-local-variables nil)
             (enable-local-eval nil))
         (htmlize-many-files command-line-args-left))))
    filenames)))

(define *mappings* (accumulator))

;; Define a mapping named @var{name}, a keyword or symbol.
;; Valid keywords are:
;;
;; @table @code
;; @item #:stem @var{string}
;; This is the constant prefix for all targets in @var{name}.
;;
;; @item #:type @var{type}
;; @var{type} is a keyword.  At this time, only
;; @code{#:module-name} is supported.
;;
;; @item #:recognize @var{recog}
;; If @var{recog} is a string, use it as the regexp to recognize text.
;; Otherwise (presuming @var{type} is @code{#:module-name}), if @var{recog} is
;; a symbol, use it to construct a regexp that matches @code{(RECOG ...)},
;; i.e., the module name whose first element is @var{recog}.  If @var{recog}
;; is @code{#f} or left unspecified, compose the regexp from the first symbol
;; in each of the keys specified in the @code{#:data} value (see below).
;;
;; @item #:lookup @var{lookup}
;; @var{lookup} is a procedure that takes two arguments: @var{data} (see
;; below) and @var{key}.  It should return the @var{leaf} associated with
;; @var{key}, or @code{#f} if not found.  This is typically @code{assoc-ref},
;; @code{assv-ref} or @code{assq-ref}.  If @var{recog} is @code{#f}, this MUST
;; be one of those for the constructed-regexp hack to work.  @var{key} will be
;; a the recognized text @code{read} as a Scheme object.  For example, when
;; @var{type} is #:module-name, @var{key} is a list of symbols.
;;
;; @item #:data @var{data}
;; @var{data} is passed to @var{lookup} as the first arg.  When @var{type} is
;; @code{#:module-name},  this MUST be an alist for the constructed-regexp
;; hack to work.
;; @end table
;;
;; The following errors may occur during operation:
;; @itemize
;; @item no htmlize-scheme mappings loaded
;; @item bad @var{part} for mapping: @var{name}
;; @end itemize
;;
;;-sig: (name [[keyword value] ...])
;;
(define (define-mapping name . args)
  (apply-to-args
   (map (lambda (kw)
          (kw-arg-ref args kw))
        '(#:stem #:type #:recognize #:lookup #:data))
   (lambda (stem type recognize lookup data)

     (define (check part ok)
       (or ok (error (fs "bad ~A for mapping: ~A" part name))))

     ;; check
     (check #:stem (string? stem))
     (check #:type (memq type '(#:module-name)))
     (check #:recognize (case type
                          ((#:module-name)
                           (or (string? recognize)
                               (symbol? recognize)
                               (and (not recognize)
                                    (memq lookup (list assq-ref
                                                       assv-ref
                                                       assoc-ref))
                                    data)))))
     (check #:lookup (procedure? lookup))

     ;; canonicalize
     (and (eq? #:module-name type)
          (not (string? recognize))
          (set! recognize (fs "\\((~{~A~^|~}) [^()]*\\)"
                              (cond ((symbol? recognize)
                                     (list recognize))
                                    ((not recognize)
                                     (uniq (map caar data)))))))

     ;; record
     (*mappings* (list name stem type recognize lookup data)))))

(define *buf* (editing-buffer (make-string (* 16 1024))))

(define (decorate!-proc css)

  (define (replacement stem leaf module-name)
    (fs "<a href=\"~A~A\">~A</a>" stem leaf module-name))

  (define (decorate-one filename)
    (editing-buffer *buf*
      (erase-buffer)
      (insert (open-input-file filename))
      (set! (filename: (current-buffer)) filename)
      ;; module names
      (let* ((read0 (lambda () (with-input-from-string (match-string 0) read)))
             (change (lambda args (replace-match (apply replacement args))))
             (mods! (lambda (regexp find-leaf stem)
                      (let ((rx (make-regexp regexp)))
                        (goto-char (point-min))
                        (let loop ()
                          (cond ((re-search-forward rx (point-max) #t)
                                 (and-let* ((module-name (read0))
                                            (leaf (find-leaf module-name)))
                                   (change stem leaf module-name))
                                 (loop))))))))
        ;; do it!
        (FE (*mappings*)
            (lambda (mapping)
              (apply-to-args
               mapping
               (lambda (name stem type recognize lookup data)
                 (mods! recognize
                        (lambda (module-name) (lookup data module-name))
                        stem))))))
      ;; css kludge
      (cond (css (goto-char (point-min))
                 (re-search-forward "^ *<style type=.text/css.>")
                 (delete-region (match-beginning 0)
                                (begin
                                  (search-forward "</style>\n")
                                  (point)))
                 (insert css)
                 (or (bolp) (insert "\n"))))
      ;; write it out
      (write-to-port (open-output-file filename))))

  ;; rv
  (lambda (filenames)
    (FE filenames decorate-one)))

(define (inline-css filename)
  (editing-buffer (find-file filename)
    (insert "<style type=\"text/css\"><!--\n")
    (goto-char (point-max))
    (or (bolp) (insert "\n"))
    (insert "--></style>\n")
    (buffer-string)))

(define (find-hmaps qop)
  (define (hmaps<-directory dir)
    (map (lambda (filename)
           (in-vicinity dir filename))
         (filtered-files (extract-stem-proc "hmap" #t) dir)))
  (let ((acc (accumulator)))
    (define (yes! ls)
      (apply acc ls))
    (qop 'load yes!)
    (qop 'hmap-dir (lambda (dirs)
                     (FE (map hmaps<-directory dirs) yes!)))
    (set! acc (acc))
    (and (null? acc)
         (error "no htmlize-scheme mappings loaded"))
    acc))

(define (main/qop qop)
  (let ((hmaps (find-hmaps qop))
        (css (qop 'css (lambda (s)
                         (cond ((string-null? s) (error "bad --css arg"))
                               ((char=? #\space (string-ref s 0)) s)
                               ((file-exists? s) (inline-css s))
                               (else (error "could not open css file:" s))))))
        (filenames (qop '())))
    (FE hmaps load-from-path)
    ;; do it!
    (make-html-files! (qop 'elisp) filenames)
    ((decorate!-proc css)
     (map (lambda (f) (string-append f ".html")) filenames))))

(define (valid-directory? filename)
  (and (access? filename (logior R_OK X_OK))
       (file-is-directory? filename)))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   ;; 1.0 -- initial release
                   ;; 1.1 -- add option --css CSS
                   ;; 1.2 -- more efficient
                   ;; 1.3 -- add options --hmap-dir, --elisp; bugfixes
                   ;; 2.0 -- drop --stem, #:stems; add #:stem
                   (version . "1.3")
                   (help . commentary)))
  (main/qop
   (qop<-args
    args `((load (single-char #\l)
                 (value #t)
                 (merge-multiple? #t)
                 (predicate ,file-exists?))
           (hmap-dir (single-char #\d)
                     (value #t)
                     (merge-multiple? #t)
                     (predicate ,valid-directory?))
           (elisp (value #t)
                  (predicate ,file-exists?))
           (css (value #t))))))

;;; htmlize-scheme ends here