blob: d91a8e5524130e35ceed0b8aad70295d7ccf4757 (
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
|
;;; 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 xml)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-41)
#:use-module (syntax-highlight lexers)
#:export (lex-xml))
(define char-set:not-whitespace
(char-set-complement char-set:whitespace))
(define char-set:xml-symbol
(char-set-union char-set:letter+digit
(char-set #\. #\- #\_ #\:)))
(define lex-comment
(lex-tag 'comment (lex-delimited "<!--" #:until "-->")))
(define lex-xml-symbol
(lex-char-set char-set:xml-symbol))
(define lex-element-name
(lex-tag 'element lex-xml-symbol))
(define lex-whitespace-maybe
(lex-maybe lex-whitespace))
(define lex-attribute
(lex-all (lex-tag 'attribute lex-xml-symbol)
lex-whitespace-maybe
(lex-string "=")
lex-whitespace-maybe
(lex-tag 'string (lex-delimited "\""))))
(define lex-open-tag
(lex-all (lex-tag 'open (lex-any (lex-string "<?")
(lex-string "<")))
lex-element-name
(lex-zero-or-more
(lex-any (lex-all lex-whitespace
lex-attribute)
lex-whitespace))
(lex-tag 'close (lex-any (lex-string ">")
(lex-string "/>")
(lex-string "?>")))))
(define lex-close-tag
(lex-all (lex-tag 'open (lex-string "</"))
lex-element-name
(lex-tag 'close (lex-string ">"))))
(define lex-entity
(lex-tag 'entity (lex-delimited "&" #:until ";")))
(define lex-text
(lex-char-set (char-set-difference char-set:full
(char-set #\< #\&))))
(define lex-whitespace-maybe
(lex-maybe lex-whitespace))
(define lex-xml-element
(lex-tag 'element lex-xml-symbol))
(define lex-xml-attribute
(lex-all (lex-tag 'attribute lex-xml-symbol)
lex-whitespace-maybe
(lex-string "=")
lex-whitespace-maybe
(lex-tag 'string (lex-delimited "\""))))
(define lex-xml
(lex-consume
(lex-any lex-comment
lex-close-tag
lex-open-tag
lex-entity
lex-text)))
(lex-xml empty-tokens (string->cursor "<foo bar=\"baz\">quux © </foo>"))
|
