Skip to content

Commit

Permalink
Merge pull request #1625 from lem-project/lisp-repl-warn-highlight
Browse files Browse the repository at this point in the history 
Highlight warning in REPL
  • Loading branch information
@cxxxr
cxxxr authored Nov 20, 2024
2 parents a2c1f6f + 2b02aee commit f515857
Show file tree
Hide file tree
Showing 2 changed files with 163 additions and 147 deletions.
292 changes: 147 additions & 145 deletions extensions/lisp-mode/grammar.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -75,153 +75,155 @@
(:greedy-repetition 1 nil :whitespace-char-class)
:whitespace-char-class :end-anchor #\( #\))))

(defun make-tmlanguage-lisp ()
(defun make-tmlanguage-lisp (&key extra-patterns)
(let ((patterns
(apply #'make-tm-patterns
(remove-if #'null
(list
(make-tm-region
`(:sequence ";")
"$"
:name 'syntax-comment-attribute)
(make-tm-region
`(:sequence "|")
`(:sequence "|"))
(make-tm-region
`(:sequence "\"")
`(:sequence "\"")
:name 'syntax-string-attribute
:patterns (make-tm-patterns
(make-tm-match "\\\\.")))
(make-tm-region
`(:sequence "#|")
`(:sequence "|#")
:name 'syntax-comment-attribute)
(make-tm-match
"\\\\.")
(make-tm-match
`(:sequence
"("
(:sequence
(append
extra-patterns
(list
(make-tm-region
`(:sequence ";")
"$"
:name 'syntax-comment-attribute)
(make-tm-region
`(:sequence "|")
`(:sequence "|"))
(make-tm-region
`(:sequence "\"")
`(:sequence "\"")
:name 'syntax-string-attribute
:patterns (make-tm-patterns
(make-tm-match "\\\\.")))
(make-tm-region
`(:sequence "#|")
`(:sequence "|#")
:name 'syntax-comment-attribute)
(make-tm-match
"\\\\.")
(make-tm-match
`(:sequence
"("
(:sequence
,(wrap-symbol-names
"defun" "defclass" "defgeneric" "defsetf" "defmacro" "defmethod"
"define-method-combination" "define-condition"
"define-setf-expander" "define-compiler-macro"
"define-modify-macro"))
(:greedy-repetition 0 1 (:register symbol)))
:captures (vector nil
(make-tm-name 'syntax-keyword-attribute)
(make-tm-name 'syntax-function-name-attribute)))
(make-tm-match
`(:sequence
"(" ,(wrap-symbol-names "defun" "defmethod")
,(ppcre:parse-string "\\s*\\(")
,(ppcre:parse-string "((?i:setf))\\s+")
(:greedy-repetition 0 1 (:register symbol)))
:captures (vector nil
(make-tm-name 'syntax-keyword-attribute)
(make-tm-name 'syntax-function-name-attribute)
(make-tm-name 'syntax-function-name-attribute)))
(make-tm-match
`(:sequence
"("
(:group :case-insensitive-p
(:register (:sequence "define-" symbol)))
(:alternation (:greedy-repetition 1 nil :whitespace-char-class)
:end-anchor)
(:greedy-repetition 0 1 (:register symbol)))
:captures (vector nil
(make-tm-name 'syntax-keyword-attribute)
(make-tm-name 'syntax-function-name-attribute)))
(make-tm-match
`(:sequence
"("
(:group :case-insensitive-p
(:register (:sequence "def" symbol)))
(:alternation (:greedy-repetition 1 nil :whitespace-char-class)
:end-anchor)
(:greedy-repetition 0 1 (:register symbol)))
:captures (vector nil
(make-tm-name 'syntax-keyword-attribute)
(make-tm-name 'syntax-function-name-attribute)))
(make-tm-match
`(:sequence
"("
,(wrap-symbol-names
"defun" "defclass" "defgeneric" "defsetf" "defmacro" "defmethod"
"define-method-combination" "define-condition"
"define-setf-expander" "define-compiler-macro"
"define-modify-macro"))
(:greedy-repetition 0 1 (:register symbol)))
:captures (vector nil
(make-tm-name 'syntax-keyword-attribute)
(make-tm-name 'syntax-function-name-attribute)))
(make-tm-match
`(:sequence
"(" ,(wrap-symbol-names "defun" "defmethod")
,(ppcre:parse-string "\\s*\\(")
,(ppcre:parse-string "((?i:setf))\\s+")
(:greedy-repetition 0 1 (:register symbol)))
:captures (vector nil
(make-tm-name 'syntax-keyword-attribute)
(make-tm-name 'syntax-function-name-attribute)
(make-tm-name 'syntax-function-name-attribute)))
(make-tm-match
`(:sequence
"("
(:group :case-insensitive-p
(:register (:sequence "define-" symbol)))
(:alternation (:greedy-repetition 1 nil :whitespace-char-class)
:end-anchor)
(:greedy-repetition 0 1 (:register symbol)))
:captures (vector nil
(make-tm-name 'syntax-keyword-attribute)
(make-tm-name 'syntax-function-name-attribute)))
(make-tm-match
`(:sequence
"("
(:group :case-insensitive-p
(:register (:sequence "def" symbol)))
(:alternation (:greedy-repetition 1 nil :whitespace-char-class)
:end-anchor)
(:greedy-repetition 0 1 (:register symbol)))
:captures (vector nil
(make-tm-name 'syntax-keyword-attribute)
(make-tm-name 'syntax-function-name-attribute)))
(make-tm-match
`(:sequence
"("
,(wrap-symbol-names
"defvar" "defparameter" "defconstant"
"define-symbol-macro")
(:greedy-repetition 0 1 (:register symbol)))
:captures (vector nil
(make-tm-name 'syntax-keyword-attribute)
(make-tm-name 'syntax-variable-attribute)))
(make-tm-match
`(:sequence
"("
,(wrap-symbol-names
"deftype" "defpackage" "defstruct" "uiop:define-package")
(:greedy-repetition 0 1 (:register symbol)))
:captures (vector nil
(make-tm-name 'syntax-keyword-attribute)
(make-tm-name 'syntax-type-attribute)))
(make-tm-match
`(:sequence
"(" ,(wrap-symbol-names "defstruct")
,(ppcre:parse-string "\\s*\\(")
(:register symbol))
:captures (vector nil
(make-tm-name 'syntax-keyword-attribute)
(make-tm-name 'syntax-type-attribute)))
(make-tm-match
`(:sequence
"("
,(wrap-symbol-names
"cond" "if" "let" "let*" "progn" "prog1"
"prog2" "lambda" "unwind-protect"
"when" "unless" "with-output-to-string"
"ignore-errors" "dotimes" "dolist" "declare"
"block" "break" "case" "ccase" "compiler-let" "ctypecase"
"declaim" "destructuring-bind" "do" "do*"
"ecase" "etypecase" "eval-when" "flet" "flet*"
"go" "handler-case" "handler-bind" "in-package"
"labels" "letf" "locally" "loop"
"macrolet" "multiple-value-bind" "multiple-value-prog1"
"proclaim" "prog" "prog*" "progv"
"restart-case" "restart-bind" "return" "return-from"
"setf" "setq" "symbol-macrolet" "tagbody" "the" "typecase"
"with-accessors" "with-compilation-unit"
"with-condition-restarts" "with-hash-table-iterator"
"with-input-from-string" "with-open-file"
"with-open-stream" "with-package-iterator"
"with-simple-restart" "with-slots" "with-standard-io-syntax"))
:captures (vector nil
(make-tm-name 'syntax-keyword-attribute)))
(make-tm-match
`(:sequence
"(" ,(wrap-symbol-names "warn" "error" "signal" "abort" "cerror"))
:captures (vector nil (make-tm-name 'syntax-warning-attribute)))
(make-tm-match
`(:sequence
symbol-boundary-begin
":" symbol
symbol-boundary-end)
:name 'syntax-builtin-attribute)
(make-tm-match
`(:sequence
(:positive-lookbehind "#")
":"
symbol
symbol-boundary-end)
:name 'syntax-builtin-attribute)
(make-tm-match
`(:sequence
symbol-boundary-begin
"&" symbol
symbol-boundary-end)
:name 'syntax-constant-attribute)
(make-tm-match
"#[+-]"
:name 'syntax-comment-attribute
:move-action (lambda (cur-point)
(ignore-errors
(skip-feature cur-point)))))))))
"defvar" "defparameter" "defconstant"
"define-symbol-macro")
(:greedy-repetition 0 1 (:register symbol)))
:captures (vector nil
(make-tm-name 'syntax-keyword-attribute)
(make-tm-name 'syntax-variable-attribute)))
(make-tm-match
`(:sequence
"("
,(wrap-symbol-names
"deftype" "defpackage" "defstruct" "uiop:define-package")
(:greedy-repetition 0 1 (:register symbol)))
:captures (vector nil
(make-tm-name 'syntax-keyword-attribute)
(make-tm-name 'syntax-type-attribute)))
(make-tm-match
`(:sequence
"(" ,(wrap-symbol-names "defstruct")
,(ppcre:parse-string "\\s*\\(")
(:register symbol))
:captures (vector nil
(make-tm-name 'syntax-keyword-attribute)
(make-tm-name 'syntax-type-attribute)))
(make-tm-match
`(:sequence
"("
,(wrap-symbol-names
"cond" "if" "let" "let*" "progn" "prog1"
"prog2" "lambda" "unwind-protect"
"when" "unless" "with-output-to-string"
"ignore-errors" "dotimes" "dolist" "declare"
"block" "break" "case" "ccase" "compiler-let" "ctypecase"
"declaim" "destructuring-bind" "do" "do*"
"ecase" "etypecase" "eval-when" "flet" "flet*"
"go" "handler-case" "handler-bind" "in-package"
"labels" "letf" "locally" "loop"
"macrolet" "multiple-value-bind" "multiple-value-prog1"
"proclaim" "prog" "prog*" "progv"
"restart-case" "restart-bind" "return" "return-from"
"setf" "setq" "symbol-macrolet" "tagbody" "the" "typecase"
"with-accessors" "with-compilation-unit"
"with-condition-restarts" "with-hash-table-iterator"
"with-input-from-string" "with-open-file"
"with-open-stream" "with-package-iterator"
"with-simple-restart" "with-slots" "with-standard-io-syntax"))
:captures (vector nil
(make-tm-name 'syntax-keyword-attribute)))
(make-tm-match
`(:sequence
"(" ,(wrap-symbol-names "warn" "error" "signal" "abort" "cerror"))
:captures (vector nil (make-tm-name 'syntax-warning-attribute)))
(make-tm-match
`(:sequence
symbol-boundary-begin
":" symbol
symbol-boundary-end)
:name 'syntax-builtin-attribute)
(make-tm-match
`(:sequence
(:positive-lookbehind "#")
":"
symbol
symbol-boundary-end)
:name 'syntax-builtin-attribute)
(make-tm-match
`(:sequence
symbol-boundary-begin
"&" symbol
symbol-boundary-end)
:name 'syntax-constant-attribute)
(make-tm-match
"#[+-]"
:name 'syntax-comment-attribute
:move-action (lambda (cur-point)
(ignore-errors
(skip-feature cur-point))))))))))
(make-tmlanguage :patterns patterns)))
18 changes: 16 additions & 2 deletions extensions/lisp-mode/repl.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,10 +6,22 @@
(define-attribute repl-result-attribute
(t :foreground :base06 :bold t))

(define-attribute warning-attribute
(:dark :foreground "yellow")
(:light :foreground "orange"))

(defvar *repl-syntax-table* (lem/buffer/syntax-table::copy-syntax-table lem-lisp-syntax:*syntax-table*))
(set-syntax-parser *repl-syntax-table*
(make-tmlanguage-lisp :extra-patterns
(list (make-tm-region
"^WARNING:"
"$"
:name 'warning-attribute))))

(define-major-mode lisp-repl-mode lisp-mode
(:name "REPL"
:keymap *lisp-repl-mode-keymap*
:syntax-table lem-lisp-syntax:*syntax-table*
:syntax-table *repl-syntax-table*
:mode-hook *lisp-repl-mode-hook*)
(cond
((eq (repl-buffer) (current-buffer))
Expand Down Expand Up @@ -490,7 +502,9 @@
(attribute
(setf current-attribute token))
(string
(insert-string point token :sticky-attribute current-attribute))))))
(if current-attribute
(insert-string point token :sticky-attribute current-attribute)
(insert-string point token)))))))

(define-command backward-prompt () ()
(when (equal (current-buffer) (repl-buffer))
Expand Down

0 comments on commit f515857

Please sign in to comment.