blob: ab46dbbbe01221cb189fa062d675c0151cc040c1 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
;;; guile-syntax-highlight --- General-purpose syntax highlighter
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;;
;;; Guile-syntax-highlight is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; Guile-syntax-highlight is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with guile-syntax-highlight. If not, see
;;; <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Syntax highlighting for Scheme.
;;
;;; Code:
(define-module (syntax-highlight scheme)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (syntax-highlight lexers)
#:export (%default-special-symbols
%default-special-prefixes
make-scheme-lexer
lex-scheme))
(define char-set:lisp-delimiters
(char-set-union char-set:whitespace
(char-set #\( #\) #\[ #\] #\{ #\})))
(define char-set:lisp-symbol
(char-set-complement char-set:lisp-delimiters))
(define %default-special-symbols
'("begin" "call-with-current-continuation" "call/cc"
"call-with-input-file" "call-with-output-file"
"case" "cond"
"do" "else" "if"
"lambda" "λ"
"let" "let*" "let-syntax" "letrec" "letrec-syntax"
"let-values" "let*-values"
"export" "import" "library" "use-module"
"and" "or"
"delay" "force"
"map" "for-each"))
(define %default-special-prefixes
'("define" "syntax"))
(define (lex-special-symbol sym)
(lex-filter (lambda (str)
(string=? sym str))
(lex-char-set char-set:lisp-symbol)))
(define (lex-special-symbol symbols prefixes)
(lex-filter (lambda (str)
(or (any (cut string=? symbols <>) symbols)
(any (cut string-prefix? <> str) prefixes)))
(lex-char-set char-set:lisp-symbol)))
(define (lex-map2 proc lexer)
(lambda (tokens cursor)
(let-values (((result remainder) (lexer tokens cursor)))
(if result
(match (token-take result 2)
((second first) ; accumulator tokens are in reverse order
(values (token-add (token-drop result 2)
(proc first second))
remainder)))
(fail)))))
(define (make-scheme-lexer special-symbols special-prefixes)
"Return a lexer that highlights Scheme source code. Tag strings
that are in SPECIAL-SYMBOLS or match one of the string prefixes in
SPECIAL-PREFIXES with the 'special' tag."
(lex-consume
(lex-any (lex-char-set char-set:whitespace)
(lex-tag 'open (lex-any* (map lex-string '("(" "[" "{"))))
(lex-tag 'close (lex-any* (map lex-string '(")" "]" "}"))))
(lex-tag 'comment (lex-delimited ";" #:until "\n"))
(lex-tag 'multi-line-comment
(lex-delimited "#|" #:until "|#" #:nested? #t))
(lex-tag 'special
(lex-filter (lambda (str)
(or (any (cut string=? <> str)
special-symbols)
(any (cut string-prefix? <> str)
special-prefixes)))
(lex-char-set char-set:lisp-symbol)))
(lex-tag 'string (lex-delimited "\""))
(lex-tag 'keyword
(lex-map2 string-append
(lex-all (lex-string "#:")
(lex-char-set char-set:lisp-symbol))))
(lex-tag 'symbol
(lex-any (lex-delimited "#{" #:until "}#")
(lex-char-set char-set:lisp-symbol))))))
(define lex-scheme
(make-scheme-lexer %default-special-symbols %default-special-prefixes))
|
