;; ;; This is a Chicken port of lisppaste's colorizing code ;; This version based on released lisppaste 2.3 ;; ;; Copyright (c) 2010-2012 Peter Bex ;; Copyright (c) 2003-2010 Brian Mastenbrook ;; ;; Permission is hereby granted, free of charge, to any person obtaining ;; a copy of this software and associated documentation files (the ;; "Software"), to deal in the Software without restriction, including ;; without limitation the rights to use, copy, modify, merge, publish, ;; distribute, sublicense, and/or sell copies of the Software, and to ;; permit persons to whom the Software is furnished to do so, subject to ;; the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; ;; TODO: ;; * Implement lookup tables in coloring-types.scm ;; * SXML output? ;; * Export more so people can implement their own colorizers. Another module? ;; * Maybe extract the useful parsing stuff from this and make it into ;; its own egg? Then we could clean up this code a lot, too. ;; I've done this port to benefit from the coloring types lisppaste has, ;; not because the colorizing macro is so elegant ;) (module colorize (html-colorize coloring-type-names coloring-type-exists? scan-string) (import (chicken base) (chicken syntax) (chicken format) (chicken string) scheme) (import srfi-13 srfi-1) (import-for-syntax (chicken keyword)) (define *coloring-types* (make-parameter '())) (define-record coloring-type fancy-name abstract? default-mode parent-type formatter-after-hook term-formatter transition-functions) (define (find-coloring-type* type) (and-let* ((make-type (alist-ref type (*coloring-types*)))) (make-type))) (define (find-coloring-type type) (let ((type (find-coloring-type* type))) (if (and type (coloring-type-abstract? type)) (error "You can't use abstract coloring types directly") type))) (define (coloring-type-names) (filter-map (lambda (t) (let ((type ((cdr t)))) (and (not (coloring-type-abstract? type)) (cons (car t) (coloring-type-fancy-name type))))) (*coloring-types*))) (define (coloring-type-exists? name) (and-let* ((make-type (alist-ref name (*coloring-types*))) (type (make-type))) (not (coloring-type-abstract? type)))) (set! (setter find-coloring-type) (lambda (type new-value) (if new-value (let ((found (assoc type (*coloring-types*)))) (if found (set! (cdr found) new-value) (*coloring-types* (append (*coloring-types*) (list (cons type new-value)))))) (*coloring-types* (remove (lambda (t) (eq? (car t) type)) (*coloring-types*)))))) (define *scan-calls* (make-parameter 0)) (define *reset-position* (make-parameter #f)) (define-syntax with-scanning-functions* (syntax-rules () ((_ (advance scan-any scan peek-any peek set-mode not-preceded-by) string-param position-place mode-place mode-wait-place body ...) (letrec ((advance (lambda (num) (set! position-place (+ position-place num)) #t)) (peek-any (lambda (items #!key not-preceded-by) (*scan-calls* (add1 (*scan-calls*))) (let* ((items (if (string? items) (string->list items) items)) (not-preceded-by (if (char? not-preceded-by) (string not-preceded-by) not-preceded-by)) (position position-place) (str string-param) (item (and (< position (string-length str)) (find (lambda (item) #;(printf "looking for ~S in ~S starting at ~S~%" item str position) (if (char? item) (char=? (string-ref str position) item) (string-contains str item position (min (string-length str) (+ position (string-length item)))))) items)))) (when (char? item) (set! item (string item))) (if (if item (if not-preceded-by (if (>= (- position (string-length not-preceded-by)) 0) (not (string=? (substring/shared str (- position (string-length not-preceded-by)) position) not-preceded-by)) #t) #t) #f) item (begin (when (*reset-position*) (set! position-place (*reset-position*))) #f))))) (scan-any (lambda (items #!key not-preceded-by) (let ((item (peek-any items :not-preceded-by not-preceded-by))) (and item (advance (string-length item)))))) (peek (lambda (item #!key not-preceded-by) (peek-any (list item) :not-preceded-by not-preceded-by))) (scan (lambda (item #!key not-preceded-by) (scan-any (list item) :not-preceded-by not-preceded-by)))) (letrec-syntax ((set-mode (syntax-rules (:until :advancing) ((_ new-mode) (set-mode new-mode :until #f :advancing #t)) ((_ new-mode :until until) (set-mode new-mode :until until :advancing #t)) ((_ new-mode :advancing advancing) (set-mode new-mode :until #f :advancing advancing)) ((_ new-mode :advancing advancing :until until) ;; Swap order (set-mode new-mode :until until :advancing advancing)) ((_ new-mode :until until :advancing advancing) (begin (set! mode-place new-mode) (set! mode-wait-place (lambda (position) (parameterize ((*reset-position* position)) (values until advancing))))))))) body ...))))) (define-syntax with-scanning-functions (er-macro-transformer (lambda (exp ren cmp) `(,(ren 'with-scanning-functions*) ;; Unhygienic names: (advance scan-any scan peek-any peek set-mode not-preceded-by) . ,(cdr exp))))) (define-syntax define-coloring-type* (syntax-rules () ((_ ?name ?fancy-name ?abstract ?default-mode ((?mode ?table ...) ...) (?formatter ...) ?parent ((?formatter-variable ?formatter-value) ...) ?formatter-after-hook ?call-parent-formatter ?call-formatter) (set! (find-coloring-type '?name) (lambda () (let ((parent-type (or (find-coloring-type* '?parent) (and '?parent (error "No such coloring type: ~S" '?parent)))) (?formatter-variable ?formatter-value) ...) (make-coloring-type ?fancy-name ?abstract (or ?default-mode (and parent-type (coloring-type-default-mode parent-type))) parent-type (lambda () ; formatter-after-hook (string-append (?formatter-after-hook) (if parent-type ((coloring-type-formatter-after-hook parent-type)) ""))) (lambda (term) ; term-formatter (letrec ((?call-parent-formatter (lambda (#!optional (type (car term)) (str (cdr term))) (if parent-type ((coloring-type-term-formatter parent-type) (cons type str)) str))) (?call-formatter (lambda (#!optional (type (car term)) (str (cdr term))) ((case (first type) ?formatter ... (else (lambda (type text) (?call-parent-formatter type text)))) type str)))) (?call-formatter))) (list (cons '?mode ; transition-functions (lambda (current-mode str position) (let ((mode-wait (constantly #f)) (position-foobage position)) (with-scanning-functions str position-foobage current-mode mode-wait (parameterize ((*reset-position* position)) (cond ?table ...)) (values position-foobage current-mode (lambda (new-position) ;; XXX: Should this be a LET? (set! position-foobage new-position) (receive (_ advance) (mode-wait position-foobage) (values position-foobage advance)))))))) ...)))))))) (define-for-syntax (maybe-keyword->symbol obj) (if (keyword? obj) (string->symbol (keyword->string obj)) obj)) (define-syntax define-coloring-type (er-macro-transformer (lambda (exp ren cmp) `(,(ren 'define-coloring-type*) ;; Some hackery to "parse" keyword args in the macro call . ,(apply (lambda (name fancy-name #!key (abstract #f) default-mode (transitions '()) (formatters '()) parent (formatter-variables '()) (formatter-after-hook `(,(ren 'constantly) ""))) (list (maybe-keyword->symbol name) fancy-name abstract default-mode transitions ;; Scheme's case construct doesn't accept single values (map (lambda (f) (if (not (pair? (car f))) (cons (list (car f)) (cdr f)) f)) formatters) (maybe-keyword->symbol parent) formatter-variables formatter-after-hook ;; Unhygienic names: 'call-parent-formatter 'call-formatter)) (cdr exp)))))) (define (full-transition-table coloring-type-object) (let ((parent (coloring-type-parent-type coloring-type-object))) (if parent (append (coloring-type-transition-functions coloring-type-object) (full-transition-table parent)) (coloring-type-transition-functions coloring-type-object)))) (define (scan-string coloring-type str) (let* ((coloring-type-object (or (find-coloring-type coloring-type) (error (sprintf "No such coloring type: ~S" coloring-type)))) (transitions (full-transition-table coloring-type-object)) (result '()) (low-bound 0) (current-mode (coloring-type-default-mode coloring-type-object)) (mode-stack '()) (current-wait (lambda _ (values #f #f))) (wait-stack '()) (current-position 0)) (call/cc ;; This shouldn't be needed but it's a straight translation from CL (lambda (return) (parameterize ((*scan-calls* 0)) (let loop ((finish-current (lambda (new-position new-mode new-wait action #!key (extend #t)) (let ((to (if extend new-position current-position))) (when (> to low-bound) (set! result (append result (list (cons (cons current-mode mode-stack) (substring/shared str low-bound to)))))) (set! low-bound to) (when (eq? action 'pop) (set! mode-stack (cdr mode-stack)) (set! wait-stack (cdr wait-stack))) (when (eq? action 'push) (set! mode-stack (cons current-mode mode-stack)) (set! wait-stack (cons current-wait wait-stack))) (set! current-mode new-mode) (set! current-position new-position) (set! current-wait new-wait)) #t))) (if (> current-position (string-length str)) (begin #;(format #t "Scan was called ~S times.~%" (*scan-calls*)) (finish-current (string-length str) #f (lambda _ (values #f #f)) 'none) (return result)) (or (any (lambda (transition-info) (and-let* ((transition-mode (car transition-info)) ((or (eqv? transition-mode current-mode) (and (list? transition-mode) (member current-mode transition-mode)))) (do-transition! (cdr transition-info))) (receive (new-position new-mode new-wait) (do-transition! current-mode str current-position) (and (> new-position current-position) (finish-current new-position new-mode new-wait 'push :extend #f))))) transitions) (receive (pos advance) (current-wait current-position) #;(format #t "current-wait returns ~S ~S (mode is ~S, pos is ~S)~%" pos advance current-mode current-position) (and pos (> pos current-position) (finish-current (if advance pos current-position) (car mode-stack) (car wait-stack) 'pop :extend advance))) (begin (set! current-position (add1 current-position)) #t))) ; #t return not necessary ;; Fugly CL loop macro. Should rewrite when this code works and ;; I understand what's really happening (loop finish-current))))))) (define (format-scan coloring-type scan) (let* ((coloring-type-object (or (find-coloring-type coloring-type) (error (sprintf "No such coloring type: ~S" coloring-type)))) (color-formatter (coloring-type-term-formatter coloring-type-object))) (string-append (string-concatenate (map color-formatter scan)) ((coloring-type-formatter-after-hook coloring-type-object))))) ;; From Spiffy: (define (htmlize str) (string-translate* str '(("<" . "<") (">" . ">") ("\"" . """) ("'" . "'") ("&" . "&")))) (define (html-colorize coloring-type string) (format-scan coloring-type (map (lambda (p) (cons (car p) (htmlize (cdr p)))) (scan-string coloring-type string)))) (include "coloring-types.scm") )