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
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
|
;;; racket-font-lock.el -*- lexical-binding: t; -*-
;; Copyright (c) 2013-2021 by Greg Hendershott.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
;; License:
;; This is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version. This 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
;; General Public License for more details. See
;; http://www.gnu.org/licenses/ for details.
(require 'cl-lib)
(require 'racket-custom)
(require 'racket-keywords-and-builtins)
(require 'racket-ppss)
(require 'racket-util)
;; Define 3 levels of font-lock, as documented in 23.6.5 "Levels of
;; Font Lock". User may control using `font-lock-maximum-decoration'.
;; Note: font-lock iterates by matcher, doing an re-search-forward
;; over the entire region. As a result, it's faster to consolidate
;; matchers that will yield the same result (unless they need to be
;; tried in a certain order).
;; Note: This relies on our character syntax already having been
;; applied. For example a Racket identifier like `|name with spaces|`
;; will already have word/symbol syntax on everything including the
;; pipe and space chars.
(defconst racket-font-lock-keywords-0
(eval-when-compile
`(
;; #shebang
(,(rx bol "#!" (+ nonl) eol) . font-lock-comment-face)
;; #lang
(,(rx (group (group "#lang")
(1+ " ")
(group (1+ not-newline))))
(2 font-lock-keyword-face nil t)
(3 font-lock-variable-name-face nil t))
;; #; sexp comments
;;
;; We don't put any comment syntax on these -- that way things
;; like indent and nav work within the sexp. They are solely
;; font-locked as comments, here.
(,#'racket--font-lock-sexp-comments)
;; #<< here strings
;;
;; We only handle the opening #<<ID here. The remainder is
;; handled in `racket-font-lock-syntatic-face-function'.
(,(rx (group "#<<" (+? (not (any blank ?\n)))) ?\n)
(1 racket-here-string-face nil t))
))
"Strings, comments, #lang.")
(defconst racket-font-lock-keywords-1
(eval-when-compile
`(
;; keyword argument
(,(rx "#:" (1+ (or (syntax word) (syntax symbol) (syntax punctuation))))
. racket-keyword-argument-face)
;; Various things for racket-selfeval-face
(,(rx (or
;; symbol
(seq ?' ?| (+ any) ?|)
(seq ?' (1+ (or (syntax word) (syntax symbol) (syntax punctuation))))
(seq "#\\" (1+ (or (syntax word) (syntax symbol) (syntax punctuation))))))
. racket-selfeval-face)
;; #rx #px
(,(rx (group (or "#rx" "#px")) ?\")
1 racket-selfeval-face)
;; Some self-eval constants
(,(regexp-opt '("#t" "#true" "#f" "#false" "+inf.0" "-inf.0" "+nan.0") 'symbols)
. racket-selfeval-face)
;; Numeric literals including Racket reader hash prefixes.
(,(rx
(seq symbol-start
(or
;; #d #e #i or no hash prefix
(seq (? "#" (any "dei"))
(? (any "-+"))
(1+ digit)
(? (any "./") (1+ digit))
(? ?e
(? (any "-+"))
(1+ digit))
(? ?+
(1+ digit)
(? (any "./") (1+ digit))
(? ?e
(? (any "-+"))
(1+ digit))
?i))
;; #x
(seq "#x"
(? (any "-+"))
(1+ hex-digit)
(? (any "./") (1+ hex-digit)))
;; #b
(seq "#b"
(or (seq (? (any "-+"))
(1+ (any "01"))
(? (any "./") (1+ (any "01"))))
(seq (1+ (any "01"))
?e
(? (any "-+"))
(1+ (any "01")))))
;; #o
(seq "#o"
(or (seq (? (any "-+"))
(1+ (any "0-7"))
(? (any "./") (1+ (any "0-7"))))
(seq (1+ (any "0-7"))
?e
(? (any "-+"))
(1+ (any "0-7"))))))
symbol-end))
. racket-selfeval-face)
))
"Self-evals")
(defconst racket-font-lock-keywords-2
(eval-when-compile
`(
;; def* -- variables
(,(rx (syntax open-parenthesis)
"def" (0+ (or (syntax word) (syntax symbol) (syntax punctuation)))
(1+ space)
(group (1+ (or (syntax word) (syntax symbol) (syntax punctuation)))))
1 font-lock-variable-name-face)
(,(rx (syntax open-parenthesis)
"define-values"
(1+ space)
(syntax open-parenthesis)
(group (1+ (or (syntax word) (syntax symbol) (syntax punctuation) space)))
(syntax close-parenthesis))
1 font-lock-variable-name-face)
;; def* -- functions
(,(rx (syntax open-parenthesis)
"def" (0+ (or (syntax word) (syntax symbol) (syntax punctuation)))
(1+ space)
(1+ (syntax open-parenthesis)) ;1+ b/c curried define
(group (1+ (or (syntax word) (syntax symbol) (syntax punctuation)))))
1 font-lock-function-name-face)
;; let identifiers
(,#'racket--font-lock-let-identifiers)
;; module and module*
(,(rx (syntax open-parenthesis)
(group "module" (? "*"))
(1+ space)
(group (1+ (or (syntax word) (syntax symbol) (syntax punctuation))))
(1+ space)
(group (1+ (or (syntax word) (syntax symbol) (syntax punctuation)))))
(1 font-lock-keyword-face nil t)
(2 font-lock-function-name-face nil t)
(3 font-lock-variable-name-face nil t))
;; module+
(,(rx (syntax open-parenthesis)
(group "module+")
(1+ space)
(group (1+ (or (syntax word) (syntax symbol) (syntax punctuation)))))
(1 font-lock-keyword-face nil t)
(2 font-lock-function-name-face nil t))
))
"Parens, modules, function/variable identifiers, syntax-")
(defconst racket-font-lock-keywords-3
(eval-when-compile
`(
(,(regexp-opt racket-keywords 'symbols) . font-lock-keyword-face)
(,(regexp-opt racket-builtins-1-of-2 'symbols) . font-lock-builtin-face)
(,(regexp-opt racket-builtins-2-of-2 'symbols) . font-lock-builtin-face)
(,(regexp-opt racket-type-list 'symbols) . font-lock-type-face)
;; pretty lambda (deprecated)
(,(rx (syntax open-parenthesis)
(? (or "case-" "match-" "opt-"))
(group "lambda")
(or word-end symbol-end))
1
(ignore
(when racket-pretty-lambda
(compose-region (match-beginning 1)
(match-end 1)
racket-lambda-char)))
nil t)
))
"Function/variable identifiers, Typed Racket types.
Note: To the extent you use #lang racket or #typed/racket, this
may be handy. But Racket is also a tool to make #lang's, and this
doesn't really fit that.")
(defconst racket-font-lock-keywords-level-0
(append racket-font-lock-keywords-0))
(defconst racket-font-lock-keywords-level-1
(append racket-font-lock-keywords-0
racket-font-lock-keywords-1))
(defconst racket-font-lock-keywords-level-2
(append racket-font-lock-keywords-0
racket-font-lock-keywords-1
racket-font-lock-keywords-2))
(defconst racket-font-lock-keywords-level-3
(append racket-font-lock-keywords-0
racket-font-lock-keywords-1
racket-font-lock-keywords-2
racket-font-lock-keywords-3))
(defconst racket-font-lock-keywords
'(racket-font-lock-keywords-level-0
racket-font-lock-keywords-level-1
racket-font-lock-keywords-level-2
racket-font-lock-keywords-level-3))
(defun racket-font-lock-syntactic-face-function (state)
(let ((q (racket--ppss-string-p state)))
(if q
(let ((startpos (racket--ppss-string/comment-start state)))
(if (eq (char-after startpos) ?|)
nil ;a |...| symbol
(if (characterp q)
font-lock-string-face
racket-here-string-face)))
font-lock-comment-face)))
;;; sexp comments
(defun racket--font-lock-sexp-comments (limit)
"Font-lock sexp comments.
Note that our syntax table intentionally does not mark these as
comments. As a result, indent and nav work within the sexp.
Instead we merely font-lock them to look like comments.
See https://docs.racket-lang.org/srfi/srfi-std/srfi-62.html for a
discussion of s-expression comments. We try to handle nesting
like \"#; #; 1 2\". For more examples see the issue 432 section
of example/example.rkt."
(while (re-search-forward (rx "#;") limit t)
(if (racket--string-or-comment-p (match-beginning 0))
(goto-char (match-end 0)) ;issues #388, #408
(let ((first-prefix-begin (match-beginning 0)))
(racket--region-set-face (match-beginning 0) (match-end 0)
'font-lock-comment-delimiter-face t)
;; Font-lock and count any additional successive prefixes
(goto-char (match-end 0))
(forward-comment (buffer-size))
(let ((num-prefixes 1))
(while (looking-at (rx "#;"))
(cl-incf num-prefixes)
(racket--region-set-face (match-beginning 0) (match-end 0)
'font-lock-comment-delimiter-face t)
(goto-char (match-end 0))
(forward-comment (buffer-size)))
;; Font-lock as many successive sexprs as prefixes
(dotimes (_ num-prefixes)
(let ((beg (point)))
(forward-sexp 1)
(racket--region-set-face beg (point)
'font-lock-comment-face t)
(forward-comment (buffer-size)))))
;; Cover everything from the beginning of the first prefix to
;; the end of the last sexp with font-lock-multiline; #443.
(put-text-property first-prefix-begin (point)
'font-lock-multiline t))))
nil)
(defun racket--string-or-comment-p (pos)
(let ((state (syntax-ppss pos)))
(or (racket--ppss-string-p state)
(racket--ppss-comment-p state))))
;;; let forms
(defun racket--font-lock-let-identifiers (limit)
"In let forms give identifiers `font-lock-variable-name-face'.
This handles both let and let-values style forms (bindings with
with single identifiers or identifier lists).
Note: This works only when the let form has a closing paren.
\(Otherwise, when you type an incomplete let form before existing
code, this would mistakenly treat the existing code as part of
the let form.) The font-lock will kick in after you type the
closing paren. Or if you use electric-pair-mode, paredit, or
similar, it will already be there."
(while (re-search-forward
(rx (syntax open-parenthesis)
(* (syntax whitespace))
(group-n 1 "let"
(* (or (syntax word) (syntax symbol) (syntax punctuation)))))
limit
t)
(ignore-errors
(when (and (not (member (match-string-no-properties 1) '("let/ec" "let/cc")))
(racket--inside-complete-sexp))
;; Resume search before this let's bindings list, so we can
;; check rhs of bindings for more lets.
(save-excursion
;; Check for named let
(when (looking-at (rx (+ space) (+ (or (syntax word)
(syntax symbol)
(syntax punctuation)))))
(forward-sexp 1)
(backward-sexp 1)
(racket--sexp-set-face font-lock-function-name-face))
;; Set font-lock-multiline property on entire identifier
;; list. Avoids need for font-lock-extend-region function.
(put-text-property (point)
(save-excursion (forward-sexp 1) (point))
'font-lock-multiline t)
(down-list 1) ;to the open paren of the first binding form
(while (ignore-errors
(down-list 1) ;to the id or list of id's
(if (not (looking-at "[([{]"))
(racket--sexp-set-face font-lock-variable-name-face)
;; list of ids, e.g. let-values
(down-list 1) ;to first id
(cl-loop
do (racket--sexp-set-face font-lock-variable-name-face)
while (ignore-errors (forward-sexp 1) (backward-sexp 1) t))
(backward-up-list))
(backward-up-list) ;to open paren of this binding form
(forward-sexp 1) ;to open paren of next binding form
t))))))
nil)
;;; misc
(defun racket--inside-complete-sexp ()
"Return whether point is inside a complete sexp."
(condition-case ()
(save-excursion (backward-up-list) (forward-sexp 1) t)
(error nil)))
(defun racket--sexp-set-face (face &optional forcep)
"Set 'face prop to FACE, rear-nonsticky, for the sexp starting at point.
Unless FORCEP is t, does so only if not already set in the
region.
Moves point to the end of the sexp."
(racket--region-set-face (point)
(progn (forward-sexp 1) (point))
face
forcep))
(defun racket--region-set-face (beg end face &optional forcep)
"Set 'face prop to FACE, rear-nonsticky, in the region BEG..END.
Unless FORCEP is t, does so only if not already set in the
region."
(when (or forcep (not (text-property-not-all beg end 'face nil)))
(add-text-properties beg end
`(face ,face
;;rear-nonsticky (face)
))))
(provide 'racket-font-lock)
;; racket-font-lock.el ends here
|
