highlight/highlight.scm

(import chicken scheme data-structures)
(use colorize irregex srfi-13 files)

(define *file* (cadr (argv)))

(define *file-contents* (read-string))

(define (guess-type-by-file-extension filename)
  (and-let* ((extension (pathname-extension (make-pathname "" filename))))
    (case (string->symbol extension)
      ((scm) 'scheme)
      ((lisp) 'lisp)
      ((el) 'elisp)
      ((c h) 'c)
      ((cpp) 'c++)
      ((java) 'java)
      ((m) 'objective-c)
      ((erl) 'erlang)
      ((py) 'python)
      ((rb) 'ruby)
      ((hs) 'haskell)
      ((diff) 'diff)
      ((css) 'css)
      ((xml) 'xml)
      ((xhtml) 'xhtml)
      ((html) 'html)
      (else #f))))

(define (guess-type-by-emacs-major-mode-variable file-contents)
  (define (file-local-variables file-contents)
    (and-let* ((match (irregex-search (irregex "^.*-\\*-.+-\\*-") file-contents)))
      (irregex-search (irregex "-\\*-.+-\\*-") (irregex-match-substring match))))
  (define (single-word-mode-line vars)
    (irregex-match (irregex "\\s*\\w+\\s*") vars))
  (define (mode-variable vars)
    (irregex-search (irregex "mode:\\s*\\w+") vars))
  (case (and-let* ((vars-match (file-local-variables file-contents))
                   (var-string (irregex-match-substring vars-match))
                   (vars (string-downcase
                          (substring var-string 3 (- (string-length var-string) 3)))))
          (cond (#f #f)
                ((single-word-mode-line vars) =>
                 (compose string->symbol string-trim-both irregex-match-substring))
                ((mode-variable vars) =>
                 (lambda (match)
                   ;; remove mode: and trim
                   (string->symbol
                    (string-trim-both (substring (irregex-match-substring match) 5)))))
                (else #f)))
    ((scheme) 'scheme)
    ((lisp) 'lisp)
    ((common-lisp) 'common-lisp)
    ((emacs-lisp) 'elisp)
    ((c h) 'c)
    ((c++) 'c++)
    ((java) 'java)
    ((erlang) 'erlang)
    ((python) 'python)
    ((ruby) 'ruby)
    ((haskell) 'haskell)
    ((diff) 'diff)
    ((css) 'css)
    ((xml) 'xml)
    ((xhtml) 'xhtml)
    ((html) 'html)
    (else #f)))

;; based on string-translate* example from CHICKEN Scheme docs
(define (text->html text)
  (string-translate*
   text
   '(("<" . "&lt;") (">" . "&gt;") ("\"" . "&quot;")
     (" " . "&nbsp;") ("'" . "&#x27;")) ))

(let ((type (or (guess-type-by-emacs-major-mode-variable *file-contents*)
                (guess-type-by-file-extension *file*))))
  (if (not type)
      (begin (display (text->html *file-contents*)) (exit 0))
      (begin
        (display
         "<style>
.code-highlight .symbol,.code-highlight .default,.code-highlight .comment {
    background-color: white;
    color:#59443C;
    font-weight:400;
}

.code-highlight i {
    font-style:normal;
}

.code-highlight i .symbol {
    color:#B64926;
}

.code-highlight .paren1,.code-highlight .paren2,.code-highlight .paren3,.code-highlight .paren4,.code-highlight .paren5,.code-highlight .paren6 {
    background-color:inherit;
}

.code-highlight .paren1:hover,.code-highlight .paren2:hover,.code-highlight .paren3:hover,.code-highlight .paren4:hover,.code-highlight .paren5:hover,.code-highlight .paren6:hover {
    color:#FFF;
    font-weight:700;
}

.code-highlight .paren1:hover {
    background-color:#DB7859;
}

.code-highlight .paren2:hover {
    background-color:#1B804C;
}

.code-highlight .paren3:hover {
    background-color:#9F214E;
}

.code-highlight .paren4:hover {
    background-color:#DBA059;
}

.code-highlight .paren5:hover {
    background-color:#B64926;
}

.code-highlight .paren6:hover {
    background-color:#64A422;
}

.code-highlight .comment {
    color:#8C8281;
    font-style:italic;
}
</style>")

        (display "<span class=\"code-highlight\">")

        (display
         (html-colorize type *file-contents*))

        (display "</span>"))))

(exit 0)