352 lines
12 KiB
EmacsLisp
352 lines
12 KiB
EmacsLisp
;;; racket-font-lock.el
|
||
|
||
;; Copyright (c) 2013-2018 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
|
||
(1 font-lock-comment-delimiter-face t)
|
||
(2 font-lock-comment-face t))
|
||
|
||
;; #<< 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))))
|
||
. racket-keyword-argument-face)
|
||
|
||
;; Various things for racket-selfeval-face
|
||
(,(rx (or
|
||
;; symbol
|
||
(seq ?' ?| (+ any) ?|)
|
||
(seq ?' (1+ (or (syntax word) (syntax symbol))))
|
||
(seq "#\\" (1+ (or (syntax word) (syntax symbol))))))
|
||
. 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"))
|
||
(or (seq (? (any "-+"))
|
||
(1+ digit)
|
||
(? (any "./") (1+ digit)))
|
||
(seq (1+ digit)
|
||
?e
|
||
(? (any "-+"))
|
||
(1+ digit))))
|
||
;; #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)))
|
||
(1+ space)
|
||
(group (1+ (or (syntax word) (syntax symbol)))))
|
||
1 font-lock-variable-name-face)
|
||
(,(rx (syntax open-parenthesis)
|
||
"define-values"
|
||
(1+ space)
|
||
(syntax open-parenthesis)
|
||
(group (1+ (or (syntax word) (syntax symbol) space)))
|
||
(syntax close-parenthesis))
|
||
1 font-lock-variable-name-face)
|
||
|
||
;; def* -- functions
|
||
(,(rx (syntax open-parenthesis)
|
||
"def" (0+ (or (syntax word) (syntax symbol)))
|
||
(1+ space)
|
||
(1+ (syntax open-parenthesis)) ;1+ b/c curried define
|
||
(group (1+ (or (syntax word) (syntax symbol)))))
|
||
1 font-lock-function-name-face)
|
||
|
||
;; let identifiers
|
||
(,#'racket--font-lock-let-identifiers . font-lock-variable-name-face)
|
||
|
||
;; module and module*
|
||
(,(rx (syntax open-parenthesis)
|
||
(group "module" (? "*"))
|
||
(1+ space)
|
||
(group (1+ (or (syntax word) (syntax symbol))))
|
||
(1+ space)
|
||
(group (1+ (or (syntax word) (syntax symbol)))))
|
||
(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)))))
|
||
(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 the syntax table does NOT show these as comments in
|
||
order to let indent and nav work within the sexp. We merely
|
||
font-lock them as comments."
|
||
(ignore-errors
|
||
(when (re-search-forward (rx (seq bol (* (not (any ?\;)))) ;Issue 388
|
||
(group-n 1 "#;" (* " "))
|
||
(group-n 2 (not (any " "))))
|
||
limit t)
|
||
(let ((md (match-data)))
|
||
(goto-char (match-beginning 2))
|
||
(forward-sexp 1)
|
||
(setf (elt md 5) (point)) ;set (match-end 2)
|
||
(set-match-data md)
|
||
t))))
|
||
|
||
|
||
;;; 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)))))
|
||
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)))))
|
||
(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
|