Syntax Highlighter in Gauche

synhl.scm

(define-module synhl
  (use text.tree)
  (export highlight))
(select-module synhl)

;(use slib)
;(require 'trace)

(define (mk-tokenizer :rest args)
  (letrec
    ((mk-tpls (lambda (n l)
                (if (null? l) '()
                  (cons (list n (car l) (cadr l))
                    (mk-tpls (+ n 1) (cddr l))))))
     (tpls (mk-tpls 1 args))
     (mf (lambda (x l)
           (cond ((null? l) #f)
                 ((not (cadr (car l))) (list #f (x)))
                 ((x (car (car l))) (list (cadr (car l)) (x)))
                 (else (mf x (cdr l))))))
     (ml (lambda (rx s)
           (cond
             ((rx s) => (lambda (x)
                          (cons (mf x tpls)
                                (ml rx (x 'after)))))
             (else '())))))
   ;(trace ml)
    (lambda (str)
      (ml (string->regexp
            (apply string-append
              (intersperse "|"
                (map (lambda (tpl) (caddr tpl)) tpls))))
        str))))

(define (er str)
  (tree->string
    (letrec
      ((rp (lambda (c)
             (cond
               ((eq? c #\<) "&lt;")
               ((eq? c #\>) "&gt;")
               ((eq? c #\") "&quot;")
               ((eq? c #\&) "&amp;")
               (else c))))
       (lp (lambda (l)
             (if (null? l)
                 '()
                 (cons (rp (car l)) (lp (cdr l)))))))
      (lp (string->list str)))))

(define (spanize class str)
  (if class
    (string-append "<span class=\"" class "\">" (er str) "</span>")
    (er str)))

(define (hs-highlight str)
  (apply string-append
    (map (lambda (cs) (spanize (car cs) (cadr cs)))
      ((mk-tokenizer
         "Comment"    "(--[^\n]*)\n"
         "Constant"   "(\"(?:[^\\\\\"]|\\\\.)*\"|\\d+)"
         "Statement"  "(=|->|\\\\|\\^|\\+|\\*)"
         "Identifier" "(let|in)"
         #f           "\\(|\\)|\\w+|\\s+") str))))

(define (scm-highlight str)
  (apply string-append
    (map (lambda (cs) (spanize (car cs) (cadr cs)))
      ((mk-tokenizer
         "Comment"    "(;[^\n]*)\n"
         "Constant"   "(\"(?:[^\\\\\"]|\\\\.)*\"|\\d+|#f|#t)"
         "Special"    "(\\(|\\))"
         "Statement"  "(define-syntax|syntax-rules|define|letrec|let|lambda|cond|\\.\\.\\.)"
         "Identifier" "(map|car|cdr|cons|apply|string-length|<|=|\\*|\\+)"
         #f           "\\w+|\\s+") str))))

(define (cl-highlight str)
  (apply string-append
    (map (lambda (cs) (spanize (car cs) (cadr cs)))
      ((mk-tokenizer
         "Comment"    "(;[^\n]*)\n"
         "Constant"   "(\"(?:[^\\\\\"]|\\\\.)*\"|\\d+)"
         "Special"    "(\\(|\\))"
         "Statement"  "(setq|let|lambda|funcall|labels|defun)"
         "Identifier" "(\\*|\\+)"
         #f           "\\w+|\\s+") str))))

(define (clj-highlight str)
  (apply string-append
    (map (lambda (cs) (spanize (car cs) (cadr cs)))
      ((mk-tokenizer
         "Comment"    "(;[^\n]*)\n"
         "Constant"   "(\"(?:[^\\\\\"]|\\\\.)*\"|\\d+)"
         "Special"    "(\\(|\\)|\\[|\\]|fn)"
         "Statement"  "(defn|def|letfn|let)"
         "Identifier" "(\\*|\\+)"
         #f           "\\w+|\\s+") str))))

(define (js-highlight str)
  (apply string-append
    (map (lambda (cs) (spanize (car cs) (cadr cs)))
      ((mk-tokenizer
         "Comment"    "(//[^\n]*)\n"
         "Constant"   "(\"(?:[^\\\\\"]|\\\\.)*\"|\\d+)"
         "Special"    "(\\(|\\)|,)"
         "Identifier" "(var|=|function|{|}|;|return|\\*|\\+)"
         #f           "\\w+|\\s+") str))))

(define (scala-highlight str)
  (apply string-append
    (map (lambda (cs) (spanize (car cs) (cadr cs)))
      ((mk-tokenizer
         "Comment"    "(//[^\n]*)\n"
         "Constant"   "(\"(?:[^\\\\\"]|\\\\.)*\"|\\d+)"
         "Special"    "(var|\\(|\\)|=>|,|:|;)"
         "Identifier" "(Int|\\*|\\+)"
         #f           "\\w+|\\s+") str))))

(define (ocaml-highlight str)
  (apply string-append
    (map (lambda (cs) (spanize (car cs) (cadr cs)))
      ((mk-tokenizer
         "Comment"    "(\\(\\*[^\\*\\)]*\\*\\))"
         "Constant"   "(\"(?:[^\\\\\"]|\\\\.)*\"|\\d+)"
         "Special"    "(let|in|fun|\\(|\\)|->|=|;;)"
         "Identifier" "(\\*|\\+)"
         #f           "\\w+|\\s+") str))))

(define (highlight lang str)
  (cond
    ((equal? lang "haskell") (hs-highlight str))
    ((equal? lang "scheme") (scm-highlight str))
    ((equal? lang "common lisp") (cl-highlight str))
    ((equal? lang "clojure") (clj-highlight str))
    ((equal? lang "javascript") (js-highlight str))
    ((equal? lang "scala") (scala-highlight str))
    ((equal? lang "ocaml") (ocaml-highlight str))
    ((equal? lang "f#") (ocaml-highlight str))
    ))

(provide "synhl")