blob: 7839b1a28333a01ba5aa05e4cad0a8b45a54316b (
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
|
;;; 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-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-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-char-set
(char-set-complement
char-set:lisp-delimiters))))))
(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 scheme-highlighter
(parse-many
(parse-any parse-whitespace
(parse-openers '("(" "[" "{"))
(parse-closers '(")" "]" "}"))
(parse-specials '("define" "lambda"))
parse-string-literal
parse-comment
parse-keyword
parse-quoted-symbol
parse-symbol)))
;; (scheme-highlighter
;; (string->stream
;; "(define* (foo bar #:key (baz 'quux))
;; \"This is a docstring!\"
;; #u8(1 2 3)
;; (1+ bar))"))
|
