f4f4ac66e64f9d393d057387e45ca16125348c63
[guile-syntax-highlight.git] / syntax-highlight / scheme.scm
1 ;;; guile-syntax-highlight --- General-purpose syntax highlighter
2 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
3 ;;;
4 ;;; Guile-syntax-highlight is free software; you can redistribute it
5 ;;; and/or modify it under the terms of the GNU Lesser General Public
6 ;;; License as published by the Free Software Foundation; either
7 ;;; version 3 of the License, or (at your option) any later version.
8 ;;;
9 ;;; Guile-syntax-highlight is distributed in the hope that it will be
10 ;;; useful, but WITHOUT ANY WARRANTY; without even the implied
11 ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
12 ;;; See the GNU Lesser General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU Lesser General Public
15 ;;; License along with guile-syntax-highlight. If not, see
16 ;;; <http://www.gnu.org/licenses/>.
17
18 ;;; Commentary:
19 ;;
20 ;; Syntax highlighting for Scheme.
21 ;;
22 ;;; Code:
23
24 (define-module (syntax-highlight scheme)
25 #:use-module (srfi srfi-1)
26 #:use-module (srfi srfi-11)
27 #:use-module (srfi srfi-41)
28 #:use-module (syntax-highlight parsers)
29 #:export (%default-special-symbols
30 %default-special-regexps
31 make-scheme-highlighter
32 scheme-highlighter))
33
34 (define char-set:lisp-delimiters
35 (char-set-union char-set:whitespace
36 (char-set #\( #\) #\[ #\] #\{ #\})))
37
38 (define (lisp-delimiter? char)
39 (char-set-contains? char-set:lisp-delimiters char))
40
41 (define parse-symbol-chars
42 (parse-char-set
43 (char-set-complement char-set:lisp-delimiters)))
44
45 (define (parse-specials special-words)
46 "Create a parser for SPECIAL-WORDS, a list of important terms for a
47 language."
48 (define (special word)
49 (let ((parser (tagged-parser 'special (parse-string word))))
50 (lambda (stream)
51 (let-values (((result rest-of-stream) (parser stream)))
52 (if (and result (lisp-delimiter? (stream-car stream)))
53 (values result rest-of-stream)
54 (parse-fail stream))))))
55
56 (fold parse-either parse-never (map special special-words)))
57
58 (define (parse-specials/regexp special-regexps)
59 (let ((merged-regexp
60 (string-join (map (lambda (regexp)
61 (string-append "(" regexp ")"))
62 special-regexps)
63 "|")))
64 (tagged-parser 'special
65 (parse-regexp merged-regexp parse-symbol-chars))))
66
67 (define (parse-openers openers)
68 (define (open opener)
69 (tagged-parser 'open (parse-string opener)))
70
71 (fold parse-either parse-never (map open openers)))
72
73 (define (parse-closers closers)
74 (define (close closer)
75 (tagged-parser 'close (parse-string closer)))
76
77 (fold parse-either parse-never (map close closers)))
78
79 (define parse-symbol
80 (tagged-parser 'symbol
81 (parse-char-set
82 (char-set-complement char-set:lisp-delimiters))))
83
84 (define parse-keyword
85 (tagged-parser 'keyword
86 (parse-map string-concatenate
87 (parse-each (parse-string "#:")
88 parse-symbol-chars))))
89
90 (define parse-string-literal
91 (tagged-parser 'string (parse-delimited "\"")))
92
93 (define parse-comment
94 (tagged-parser 'comment (parse-delimited ";" #:until "\n")))
95
96 (define parse-quoted-symbol
97 (tagged-parser 'symbol (parse-delimited "#{" #:until "}#")))
98
99 (define %default-special-symbols
100 '("define" "begin" "call-with-current-continuation" "call/cc"
101 "call-with-input-file" "call-with-output-file"
102 "case" "cond"
103 "do" "else" "if"
104 "lambda" "λ"
105 "let" "let*" "let-syntax" "letrec" "letrec-syntax"
106 "export" "import" "library" "define-module" "use-module"
107 "let-values" "let*-values"
108 "and" "or"
109 "delay" "force"
110 "map" "for-each"
111 "syntax" "syntax-rules"))
112
113 (define %default-special-regexps
114 '("^define"))
115
116 (define* (make-scheme-highlighter special-symbols special-regexps)
117 "Create a syntax highlighting procedure for Scheme that associates
118 the 'special' tag for symbols appearing in the list SPECIAL-SYMBOLS or
119 matching a regular expression in SPECIAL-REGEXPS."
120 (parse-many
121 (parse-any parse-whitespace
122 (parse-openers '("(" "[" "{"))
123 (parse-closers '(")" "]" "}"))
124 (parse-specials special-symbols)
125 (parse-specials/regexp special-regexps)
126 parse-string-literal
127 parse-comment
128 parse-keyword
129 parse-quoted-symbol
130 parse-symbol)))
131
132 (define scheme-highlighter
133 (make-scheme-highlighter %default-special-symbols
134 %default-special-regexps))