source: project/release/4/colorize/trunk/colorize.scm @ 27134

Last change on this file since 27134 was 27134, checked in by sjamaan, 9 years ago

colorize: Add (initial version of) css language support

File size: 17.8 KB
Line 
1;;
2;; This is a Chicken port of lisppaste's colorizing code
3;; This version based on released lisppaste 2.3
4;;
5;; Copyright (c) 2010-2012 Peter Bex
6;; Copyright (c) 2003-2010 Brian Mastenbrook
7;;
8;; Permission is hereby granted, free of charge, to any person obtaining
9;; a copy of this software and associated documentation files (the
10;; "Software"), to deal in the Software without restriction, including
11;; without limitation the rights to use, copy, modify, merge, publish,
12;; distribute, sublicense, and/or sell copies of the Software, and to
13;; permit persons to whom the Software is furnished to do so, subject to
14;; the following conditions:
15;;
16;; The above copyright notice and this permission notice shall be
17;; included in all copies or substantial portions of the Software.
18;;
19;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
20;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
21;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
22;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
23;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
24;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
25;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
26;;
27;; TODO:
28;; * Implement lookup tables in coloring-types.scm
29;; * SXML output?
30;; * Export more so people can implement their own colorizers. Another module?
31;; * Maybe extract the useful parsing stuff from this and make it into
32;;    its own egg?  Then we could clean up this code a lot, too.
33;;    I've done this port to benefit from the coloring types lisppaste has,
34;;    not because the colorizing macro is so elegant ;)
35
36(module colorize
37  (html-colorize coloring-type-names coloring-type-exists? scan-string)
38
39(import chicken scheme)
40(use data-structures extras srfi-1 srfi-13)
41
42(define *coloring-types* (make-parameter '()))
43
44(define-record coloring-type
45  fancy-name abstract? default-mode parent-type
46  formatter-after-hook term-formatter transition-functions)
47
48(define (find-coloring-type* type)
49  (and-let* ((make-type (alist-ref type (*coloring-types*))))
50    (make-type)))
51
52(define (find-coloring-type type)
53  (let ((type (find-coloring-type* type)))
54    (if (and type (coloring-type-abstract? type))
55        (error "You can't use abstract coloring types directly")
56        type)))
57
58(define (coloring-type-names)
59  (filter-map (lambda (t)
60                (let ((type ((cdr t))))
61                  (and (not (coloring-type-abstract? type))
62                       (cons (car t) (coloring-type-fancy-name type)))))
63              (*coloring-types*)))
64
65(define (coloring-type-exists? name)
66  (and-let* ((make-type (alist-ref name (*coloring-types*)))
67             (type (make-type)))
68    (not (coloring-type-abstract? type))))
69
70(set! (setter find-coloring-type)
71      (lambda (type new-value)
72        (if new-value
73            (let ((found (assoc type (*coloring-types*))))
74              (if found
75                  (set! (cdr found) new-value)
76                  (*coloring-types*
77                   (append (*coloring-types*)
78                           (list (cons type new-value))))))
79            (*coloring-types* (remove (lambda (t)
80                                        (eq? (car t) type))
81                                      (*coloring-types*))))))
82
83(define *scan-calls* (make-parameter 0))
84
85(define *reset-position* (make-parameter #f))
86
87(define-syntax with-scanning-functions*
88  (syntax-rules ()
89    ((_ (advance scan-any scan peek-any peek set-mode not-preceded-by)
90        string-param position-place mode-place mode-wait-place body ...)
91     (letrec ((advance (lambda (num)
92                         (set! position-place (+ position-place num))
93                         #t))
94              (peek-any (lambda (items #!key not-preceded-by)
95                          (*scan-calls* (add1 (*scan-calls*)))
96                          (let* ((items (if (string? items)
97                                            (string->list items)
98                                            items))
99                                 (not-preceded-by (if (char? not-preceded-by)
100                                                      (string not-preceded-by)
101                                                      not-preceded-by))
102                                 (position position-place)
103                                 (str string-param)
104                                 (item
105                                  (and
106                                   (< position (string-length str))
107                                   (find (lambda (item)
108                                           #;(printf "looking for ~S in ~S starting at ~S~%"
109                                                   item str position)
110                                           (if (char? item)
111                                               (char=? (string-ref str position)
112                                                       item)
113                                               (string-contains
114                                                str item
115                                                position
116                                                (min (string-length str)
117                                                     (+ position (string-length
118                                                                  item))))))
119                                         items))))
120                            (when (char? item)
121                              (set! item (string item)))
122                            (if
123                             (if item
124                                 (if not-preceded-by
125                                     (if (>= (- position (string-length not-preceded-by)) 0)
126                                         (not (string=?
127                                               (substring/shared
128                                                str (- position (string-length not-preceded-by)) position)
129                                               not-preceded-by))
130                                         #t)
131                                     #t)
132                                 #f)
133                             item
134                             (begin
135                               (when (*reset-position*)
136                                 (set! position-place (*reset-position*)))
137                               #f)))))
138              (scan-any (lambda (items #!key not-preceded-by)
139                          (let ((item (peek-any items :not-preceded-by not-preceded-by)))
140                            (and item (advance (string-length item))))))
141              (peek (lambda (item #!key not-preceded-by)
142                      (peek-any (list item) :not-preceded-by not-preceded-by)))
143              (scan (lambda (item #!key not-preceded-by)
144                      (scan-any (list item) :not-preceded-by not-preceded-by))))
145       (letrec-syntax ((set-mode
146                        (syntax-rules (:until :advancing)
147                          ((_ new-mode)
148                           (set-mode new-mode :until #f :advancing #t))
149                          ((_ new-mode :until until)
150                           (set-mode new-mode :until until :advancing #t))
151                          ((_ new-mode :advancing advancing)
152                           (set-mode new-mode :until #f :advancing advancing))
153                          ((_ new-mode :advancing advancing :until until)
154                           ;; Swap order
155                           (set-mode new-mode :until until :advancing advancing))
156                          ((_ new-mode :until until :advancing advancing)
157                           (begin
158                             (set! mode-place new-mode)
159                             (set! mode-wait-place
160                                   (lambda (position)
161                                     (parameterize ((*reset-position* position))
162                                       (values until advancing)))))))))
163         body ...)))))
164
165(define-syntax with-scanning-functions
166  (er-macro-transformer
167   (lambda (exp ren cmp)
168     `(,(ren 'with-scanning-functions*)
169       ;; Unhygienic names:
170       (advance scan-any scan peek-any peek set-mode not-preceded-by)
171       . ,(cdr exp)))))
172
173(define-syntax define-coloring-type*
174  (syntax-rules ()
175    ((_ ?name ?fancy-name ?abstract ?default-mode ((?mode ?table ...) ...)
176        (?formatter ...) ?parent ((?formatter-variable ?formatter-value) ...)
177        ?formatter-after-hook ?call-parent-formatter ?call-formatter)
178     (set! (find-coloring-type '?name)
179           (lambda ()
180             (let ((parent-type
181                    (or (find-coloring-type* '?parent)
182                        (and '?parent
183                             (error "No such coloring type: ~S" '?parent))))
184                   (?formatter-variable ?formatter-value) ...)
185               (make-coloring-type
186                ?fancy-name
187                ?abstract
188                (or ?default-mode
189                    (and parent-type (coloring-type-default-mode parent-type)))
190                parent-type
191                (lambda ()              ; formatter-after-hook
192                  (string-append
193                   (?formatter-after-hook)
194                   (if parent-type
195                       ((coloring-type-formatter-after-hook parent-type))
196                       "")))
197                (lambda (term)          ; term-formatter
198                  (letrec ((?call-parent-formatter
199                            (lambda (#!optional (type (car term))
200                                                (str (cdr term)))
201                              (if parent-type
202                                  ((coloring-type-term-formatter parent-type)
203                                   (cons type str))
204                                  str)))
205                           (?call-formatter
206                            (lambda (#!optional (type (car term))
207                                                (str (cdr term)))
208                              ((case (first type)
209                                 ?formatter ...
210                                 (else (lambda (type text)
211                                         (?call-parent-formatter type text))))
212                               type str))))
213                    (?call-formatter)))
214                (list (cons '?mode      ; transition-functions
215                            (lambda (current-mode str position)
216                              (let ((mode-wait (constantly #f))
217                                    (position-foobage position))
218                                (with-scanning-functions
219                                 str position-foobage current-mode mode-wait
220                                 (parameterize ((*reset-position* position))
221                                   (cond ?table ...))
222                                 (values position-foobage current-mode
223                                         (lambda (new-position)
224                                           ;; XXX: Should this be a LET?
225                                           (set! position-foobage new-position)
226                                           (receive (_ advance)
227                                             (mode-wait position-foobage)
228                                             (values position-foobage advance))))))))
229                      ...))))))))
230
231(define-for-syntax (maybe-keyword->symbol obj)
232  (if (keyword? obj)
233      (string->symbol (keyword->string obj))
234      obj))
235
236(define-syntax define-coloring-type
237  (er-macro-transformer
238   (lambda (exp ren cmp)
239     `(,(ren 'define-coloring-type*)
240       ;; Some hackery to "parse" keyword args in the macro call
241        . ,(apply (lambda (name fancy-name #!key (abstract #f)
242                                default-mode (transitions '())
243                                (formatters '()) parent
244                                (formatter-variables '())
245                                (formatter-after-hook `(,(ren 'constantly) "")))
246                    (list (maybe-keyword->symbol name) fancy-name abstract
247                          default-mode transitions
248                          ;; Scheme's case construct doesn't accept single values
249                          (map (lambda (f)
250                                 (if (not (pair? (car f)))
251                                     (cons (list (car f)) (cdr f))
252                                     f))
253                               formatters)
254                          (maybe-keyword->symbol parent)
255                          formatter-variables formatter-after-hook
256                          ;; Unhygienic names:
257                          'call-parent-formatter 'call-formatter)) (cdr exp))))))
258
259(define (full-transition-table coloring-type-object)
260  (let ((parent (coloring-type-parent-type coloring-type-object)))
261    (if parent
262        (append (coloring-type-transition-functions coloring-type-object)
263                (full-transition-table parent))
264        (coloring-type-transition-functions coloring-type-object))))
265
266(define (scan-string coloring-type str)
267  (let* ((coloring-type-object
268          (or (find-coloring-type coloring-type)
269              (error (sprintf "No such coloring type: ~S" coloring-type))))
270         (transitions (full-transition-table coloring-type-object))
271         (result '())
272         (low-bound 0)
273         (current-mode (coloring-type-default-mode coloring-type-object))
274         (mode-stack '())
275         (current-wait (lambda _ (values #f #f)))
276         (wait-stack '())
277         (current-position 0))
278    (call/cc ;; This shouldn't be needed but it's a straight translation from CL
279     (lambda (return)
280       (parameterize ((*scan-calls* 0))
281         (let loop ((finish-current
282                     (lambda (new-position new-mode new-wait action
283                                           #!key (extend #t))
284                       (let ((to (if extend new-position current-position)))
285                         (when (> to low-bound)
286                           (set! result
287                                 (append result
288                                         (list (cons (cons current-mode
289                                                           mode-stack)
290                                                     (substring/shared
291                                                      str low-bound to))))))
292                         (set! low-bound to)
293                         (when (eq? action 'pop)
294                           (set! mode-stack (cdr mode-stack))
295                           (set! wait-stack (cdr wait-stack)))
296                         (when (eq? action 'push)
297                           (set! mode-stack (cons current-mode mode-stack))
298                           (set! wait-stack (cons current-wait wait-stack)))
299                         (set! current-mode new-mode)
300                         (set! current-position new-position)
301                         (set! current-wait new-wait))
302                       #t)))
303           (if (> current-position (string-length str))
304               (begin
305                 #;(format #t "Scan was called ~S times.~%"
306                         (*scan-calls*))
307                 (finish-current (string-length str) #f
308                                 (lambda _ (values #f #f)) 'none)
309                 (return result))
310               (or (any (lambda (transition-info)
311                          (and-let* ((transition-mode (car transition-info))
312                                     ((or (eqv? transition-mode current-mode)
313                                          (and (list? transition-mode)
314                                               (member current-mode
315                                                       transition-mode))))
316                                     (do-transition! (cdr transition-info)))
317                            (receive (new-position new-mode new-wait)
318                              (do-transition! current-mode str current-position)
319                              (and (> new-position current-position)
320                                   (finish-current new-position new-mode
321                                                   new-wait 'push
322                                                   :extend #f)))))
323                        transitions)
324                   (receive (pos advance)
325                     (current-wait current-position)
326                     #;(format #t "current-wait returns ~S ~S (mode is ~S, pos is ~S)~%" pos advance current-mode current-position)
327                     (and pos
328                          (> pos current-position)
329                          (finish-current (if advance
330                                              pos
331                                              current-position)
332                                          (car mode-stack)
333                                          (car wait-stack)
334                                          'pop
335                                          :extend advance)))
336                   (begin
337                     (set! current-position (add1 current-position))
338                     #t))) ; #t return not necessary
339           ;; Fugly CL loop macro. Should rewrite when this code works and
340           ;; I understand what's really happening
341           (loop finish-current)))))))
342
343(define (format-scan coloring-type scan)
344  (let* ((coloring-type-object
345          (or (find-coloring-type coloring-type)
346              (error (sprintf "No such coloring type: ~S" coloring-type))))
347         (color-formatter (coloring-type-term-formatter coloring-type-object)))
348    (string-append (string-concatenate (map color-formatter scan))
349                   ((coloring-type-formatter-after-hook coloring-type-object)))))
350
351;; From Spiffy:
352(define (htmlize str)
353  (string-translate* str '(("<" . "&lt;")    (">" . "&gt;")
354                           ("\"" . "&quot;") ("'" . "&#x27;") ("&" . "&amp;"))))
355
356(define (html-colorize coloring-type string)
357  (format-scan coloring-type
358               (map (lambda (p) (cons (car p) (htmlize (cdr p))))
359                    (scan-string coloring-type string))))
360
361(include "coloring-types.scm")
362)
Note: See TracBrowser for help on using the repository browser.