blob: 78f215094a7a7a4e68cd58c5c2f224410f8b3bbf (
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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
;;; 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 (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-41)
#:use-module (syntax-highlight parsers)
#:export (scheme-highlighter))
(define char-set:lisp-delimiters
(char-set-union char-set:whitespace
(char-set #\( #\) #\[ #\] #\{ #\})))
(define (lisp-delimiter? char)
(char-set-contains? char-set:lisp-delimiters char))
(define parse-symbol-chars
(parse-char-set
(char-set-complement char-set:lisp-delimiters)))
(define (parse-specials special-words)
"Create a parser for SPECIAL-WORDS, a list of important terms for a
language."
(define (special word)
(let ((parser (tagged-parser 'special (parse-string word))))
(lambda (stream)
(let-values (((result rest-of-stream) (parser stream)))
(if (and result (lisp-delimiter? (stream-car stream)))
(values result rest-of-stream)
(parse-fail stream))))))
(fold parse-either parse-never (map special special-words)))
(define (parse-specials/regexp special-regexps)
(let ((merged-regexp
(string-join (map (lambda (regexp)
(string-append "(" regexp ")"))
special-regexps)
"|")))
(tagged-parser 'special
(parse-regexp merged-regexp parse-symbol-chars))))
(define (parse-openers openers)
(define (open opener)
(tagged-parser 'open (parse-string opener)))
(fold parse-either parse-never (map open openers)))
(define (parse-closers closers)
(define (close closer)
(tagged-parser 'close (parse-string closer)))
(fold parse-either parse-never (map close closers)))
(define parse-symbol
(tagged-parser 'symbol
(parse-char-set
(char-set-complement char-set:lisp-delimiters))))
(define parse-keyword
(tagged-parser 'keyword
(parse-map string-concatenate
(parse-each (parse-string "#:")
parse-symbol-chars))))
(define parse-string-literal
(tagged-parser 'string (parse-delimited "\"")))
(define parse-comment
(tagged-parser 'comment (parse-delimited ";" #:until "\n")))
(define parse-quoted-symbol
(tagged-parser 'symbol (parse-delimited "#{" #:until "}#")))
(define %default-special-symbols
'("define" "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"
"export" "import" "library" "define-module" "use-module"
"let-values" "let*-values"
"and" "or"
"delay" "force"
"map" "for-each"
"syntax" "syntax-rules"))
(define %default-special-regexps
'("^define"))
(define scheme-highlighter
(parse-many
(parse-any parse-whitespace
(parse-openers '("(" "[" "{"))
(parse-closers '(")" "]" "}"))
(parse-specials %default-special-symbols)
(parse-specials/regexp %default-special-regexps)
parse-string-literal
parse-comment
parse-keyword
parse-quoted-symbol
parse-symbol)))
|
