Skip to content

Instantly share code, notes, and snippets.

@calsys456

calsys456/colourful.lisp

Created March 29, 2025 18:46
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save calsys456/9acae9310934cd7f2b1066b583dcebe1 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save calsys456/9acae9310934cd7f2b1066b583dcebe1 to your computer and use it in GitHub Desktop.
Download ZIP
Lem plugins
Raw
colourful.lisp
(defpackage colourful
(:use :cl :lem)
(:import-from :lem/buffer/line :line-add-property)
(:import-from :lem/buffer/internal :point-line)
(:export
:colourful-mode
:syntax-special-operator-attribute
:syntax-macro-attribute
:*paren-colours-for-light*
:*paren-colours-for-dark*))
(in-package :colourful)
(define-attribute syntax-special-operator-attribute
(:light :foreground "#008688" :bold t)
(:dark :foreground "#8DEEEE" :bold t))
(define-attribute syntax-macro-attribute
(:light :foreground "#6959CD")
(:dark :foreground "#BCEE68"))
(defvar *paren-colours-for-light*
'("red" "black" "darkgreen" "darkorange" "blue" "purple"))
(defvar *paren-colours-for-dark*
'("violet" "lightgreen" "pink" "skyblue1" "salmon" "yellow"))
;; Symbol categories
(defvar *special-operators*
(loop :for sym :being :each :present-symbol :of (find-package "CL")
:when (special-operator-p sym) :collect sym))
(defvar *loop-keywords-names*
'("named"
"initially" "finally" "for" "as" "with"
"do" "collect" "collecting" "append"
"appending" "nconc" "nconcing" "into" "count"
"counting" "sum" "summing" "maximize" "return" "loop-finish"
"maximizing" "minimize" "minimizing" "doing"
"thereis" "always" "never" "if" "when"
"unless" "repeat" "while" "until"
"=" "and" "it" "else" "end" "from" "upfrom"
"above" "below" "to" "upto" "downto" "downfrom"
"in" "on" "then" "across" "being" "each" "the" "hash-key"
"hash-keys" "of" "using" "hash-value" "hash-values"
"symbol" "symbols" "present-symbol"
"present-symbols" "external-symbol"
"external-symbols" "fixnum" "float" "of-type")
"Loop keywords from https://lispcookbook.github.io/cl-cookbook/iteration.html#appendix-list-of-loop-keywords")
;; Utils
(defun collect-forms (point)
(with-point ((start point)
(end point))
(loop :do (unless (form-offset end 1)
(loop-finish))
(move-point start end)
(form-offset start -1)
:collect (list (copy-point start)
(copy-point end)))))
(defun count-success-quotes-before (point)
(let ((buffer (point-buffer point))
(count 0))
(with-point ((start (buffer-start-point buffer)))
(loop
(unless (search-forward start "\"") (return))
(when (point> start point) (return))
(when (evenp (loop :for i :downfrom -2
:for c = (character-at start i)
:until (not (eql c #\\))
:count (eql c #\\)))
(incf count))))
count))
(defun try-skip-a-quote-backward (point)
(loop :until (and (eql (character-at point 0) #\")
(if (eql (character-at point -1) #\\)
(let ((count (loop for i downfrom -1
for c = (character-at point i)
until (not (eql c #\\))
count (eql c #\\))))
(evenp count))
t))
:while (character-offset point -1)))
(defun try-skip-a-quote-forward (point)
(loop :until (and (eql (character-at point -1) #\")
(if (eql (character-at point -2) #\\)
(let ((count (loop :for i :downfrom -2
:for c = (character-at point i)
:until (not (eql c #\\))
:count (eql c #\\))))
(evenp count))
t))
:while (character-offset point 1)))
;; Fontifying
(defun apply-highlight (start end attr)
(put-text-property start end :attribute attr))
(defun fontify-symbol (start end)
(let* ((str (points-to-string start end))
(split (split-sequence:split-sequence #\: str))
(symname (string-upcase (car (last split))))
(sympak (or (when (> (length split) 1)
(find-package (if (string= (car split) "")
"KEYWORD"
(string-upcase (car split)))))
(let ((name (lem-lisp-mode:buffer-package (point-buffer start))))
(when (and name (find-package name))
name))
*package*)))
(multiple-value-bind (sym status)
(find-symbol symname sympak)
(let ((face (if status
(cond ((member sym '(t nil))
'syntax-special-operator-attribute)
((member sym *special-operators*)
'syntax-special-operator-attribute)
((macro-function sym)
'syntax-macro-attribute)
((eq (symbol-package sym) (find-package "KEYWORD"))
'syntax-builtin-attribute)
((char= (schar str 0) #\&)
'syntax-special-operator-attribute)
((or (find-class sym nil) (find-package sym))
'syntax-type-attribute)
((fboundp sym) 'syntax-function-name-attribute)
((boundp sym) 'syntax-variable-attribute)
(t nil))
(cond ((string= (car split) "")
'syntax-builtin-attribute)
((find-package symname)
'syntax-type-attribute)))))
(if (and (> (length split) 1)
(> (length (car split)) 0))
(with-point ((p start))
(character-offset p (+ (length (car split))
(1- (length split))))
(apply-highlight start p 'syntax-type-attribute)
(when face (apply-highlight p end face)))
(when face (apply-highlight start end face)))))))
(defun fontify-single-form (start end)
"Fontify a single form, can be a symbol or a list, with prefix
characters.
This function is used to separate prefix & form, colouring prefix
characters, sending rest of the form to fontify-list or
fontify-symbol."
(with-point ((point start))
(loop :while (syntax-expr-prefix-char-p (character-at point 0))
:do (character-offset point 1))
(let ((c (character-at point 0)))
(cond ((syntax-open-paren-char-p c)
(apply-highlight start point 'syntax-special-operator-attribute)
(fontify-list point end))
((or (not (standard-char-p c))
(syntax-symbol-char-p c))
(apply-highlight start point 'syntax-special-operator-attribute)
(fontify-symbol point end))))))
(defun fontify-loop (lst)
"Highlight loop keywords"
(let ((1st (pop lst)))
(apply-highlight (first 1st) (second 1st) 'syntax-macro-attribute))
(dolist (form lst)
(let* ((start (first form))
(end (second form))
(str (points-to-string start end)))
(if (member str *loop-keywords-names* :test #'string-equal)
(apply-highlight start end 'syntax-builtin-attribute)
(fontify-single-form start end)))))
(defun fontify-declaration-list (lst)
;; FIXME: buggy?
(let ((1st (pop lst)))
(apply-highlight (first 1st) (second 1st) 'syntax-type-attribute))
(dolist (form lst)
(let* ((start (first form))
(c (loop :for c = (character-at start 0)
:while (syntax-expr-prefix-char-p c)
:do (character-offset start 1)
:finally (return c))))
(when (syntax-open-paren-char-p c)
(scan-lists start 1 -1 t)
(let ((children (collect-forms start)))
(when children (fontify-declaration-list children)))))))
(defun fontify-list (start &optional end)
"Parse items inside the list, sends them to corresponding fontify
functions."
(declare (ignore end))
(scan-lists start 1 -1 t)
;; Collect sub forms inside the list
(alexandria:when-let (forms (collect-forms start))
(let ((1st (apply #'points-to-string (first forms))))
;; We can add conditions here, to apply custom fontify
;; function for specific clause
(cond ((member 1st '("declare" "proclaim" "declaim")
:test #'string-equal)
(fontify-declaration-list forms))
((string-equal 1st "loop")
(fontify-loop forms))
(t (dolist (l forms) (apply #'fontify-single-form l)))))))
(defun fontify-syntactical-region (start end)
(let ((paren-index 0)
(colours (if (display-dark-p) *paren-colours-for-dark* *paren-colours-for-light*)))
(with-point ((point start))
(loop :while (scan-lists point -1 1 t))
(loop :do (skip-chars-forward
point (lambda (c) (not (member c '(#\; #\" #\# #\\ #\()))))
:while (point<= point end)
:do (case (character-at point 0)
(#\; (with-point ((start point))
(if (line-offset point 1)
(apply-highlight start point 'syntax-comment-attribute)
(return))))
(#\" (with-point ((start point))
(if (form-offset point 1)
(apply-highlight start point 'syntax-string-attribute)
(return))))
(#\\ (character-offset point 2))
(#\# (if (and (not (syntax-symbol-char-p (character-at point -1)))
(member (character-at point 1) '(#\\ #\| #\+ #\-)))
(with-point ((start point))
(let (face)
(case (character-at point 1)
(#\\ (unless (form-offset point 1) (return)))
(#\| (setq face 'syntax-comment-attribute)
(unless (form-offset point 1) (return)))
(#\+ (setq face 'syntax-comment-attribute)
(ignore-errors
(lem-lisp-mode/grammar::skip-feature point)))
(#\- (setq face 'syntax-comment-attribute)
(ignore-errors
(lem-lisp-mode/grammar::skip-feature point)))
(t (return)))
(when face (apply-highlight start point face))))
(character-offset point 1)))
(#\( (when (eql (character-at point -1) #\Newline)
(setq paren-index 0))
(let ((attr (make-attribute
:foreground (nth (mod paren-index (length colours))
colours))))
(with-point ((end point))
(when (and (form-offset end 1)
(eql (character-at end -1) #\)))
(let ((col (point-charpos end)))
(line-add-property (point-line end) (1- col) col
:attribute attr nil))
(let ((col (point-charpos point)))
(line-add-property (point-line point) col (1+ col)
:attribute attr nil))
(incf paren-index)))
(character-offset point 1)))
(t (return)))))))
(defun fontify-keywords-region (start end)
"Colouring forms covered by START and END."
(when (oddp (count-success-quotes-before start))
(try-skip-a-quote-backward start))
(when (oddp (count-success-quotes-before end))
(try-skip-a-quote-forward end))
(with-point ((form-start end))
(loop :while (scan-lists form-start -1 1 t)
:until (point< form-start start))
(if (point< form-start start)
;; If the region is inside one form
(with-point ((form-end form-start))
(form-offset form-end 1)
(remove-text-property form-start form-end :attribute)
(fontify-single-form form-start form-end)
(fontify-syntactical-region form-start form-end))
;; If the region has crossed the top-level
(progn
(move-point form-start start)
(loop :while (scan-lists form-start -1 1 t))
(with-point ((form-end form-start))
(loop :while (form-offset form-end 1)
:do (move-point form-start form-end)
(form-offset form-start -1)
(remove-text-property form-start form-end :attribute)
(fontify-single-form form-start form-end)
:until (point> form-end end)))
(fontify-syntactical-region start end)))))
;; Lem tmlanguage integration
(defclass colourful (lem/buffer/internal::tmlanguage) ())
(defun enable-colourful-mode ()
(set-syntax-parser lem-lisp-syntax:*syntax-table* (make-instance 'colourful)))
(defun disable-colourful-mode ()
(set-syntax-parser lem-lisp-syntax:*syntax-table*
(lem-lisp-mode/grammar::make-tmlanguage-lisp)))
(defmethod lem/buffer/internal::%syntax-scan-region ((self colourful) start end)
(fontify-keywords-region start end))
(define-minor-mode colourful-mode
(:name "Colour"
:global t
:description "An elaborate Lisp syntax highlighting."
:enable-hook 'enable-colourful-mode
:disable-hook 'disable-colourful-mode))
Raw
expand-region.lisp
(in-package :lem-user)
(defun expand-region-1 (start end)
"Core function of expand region.
Giving two points (START END), moves the points to expanded position
and returns them.
The expansion criteria is determined by the position and inner string
of the points, can be expanded to current word, current form, upper
form, upper string, or the whole buffer."
(flet ((count-success-quotes-before (point)
(let ((buffer (point-buffer point))
(count 0))
(with-point ((start (buffer-start-point buffer)))
(loop
(unless (search-forward start "\"") (return))
(when (point> start point) (return))
(when (evenp (loop for i downfrom -2
for c = (character-at start i)
until (not (eql c #\\))
count (eql c #\\)))
(incf count))))
count))
(try-skip-to-quote-backward (point)
(loop until (and (eql (character-at point -1) #\")
(if (eql (character-at point -2) #\\)
(let ((count (loop for i downfrom -2
for c = (character-at point i)
until (not (eql c #\\))
count (eql c #\\))))
(evenp count))
t))
while (character-offset point -1)))
(try-skip-to-quote-forward (point)
(loop until (and (eql (character-at point 0) #\")
(if (eql (character-at point -1) #\\)
(let ((count (loop for i downfrom -1
for c = (character-at point i)
until (not (eql c #\\))
count (eql c #\\))))
(evenp count))
t))
while (character-offset point 1))))
(prog ((str (points-to-string start end))
(prev-char (character-at start -1))
(next-char (character-at end 0)))
(cond ((or (and (point= start end)
(or (and prev-char (alphanumericp prev-char))
(and next-char (alphanumericp next-char))))
(and (every #'alphanumericp str)
(or (syntax-word-char-p prev-char)
(syntax-word-char-p next-char))))
(if (syntax-word-char-p next-char)
(go word-before)
(go word-current)
))
((and (eql prev-char #\")
(not (eql (character-at start -2) #\\))
(eql next-char #\")
(not (eql (character-at end 1) #\\)))
(go upper-string))
((or (point= start end)
(and (every #'syntax-symbol-char-p str)
(or (syntax-symbol-char-p prev-char)
(syntax-symbol-char-p next-char))))
(if (or (syntax-space-char-p prev-char)
(syntax-expr-prefix-char-p prev-char))
(go form-current)
(go form-before)))
((oddp (count-success-quotes-before start))
(go string-content))
((or (form-offset start -1)
(form-offset end 1))
(go list-content))
(t (go upper-form)))
word-before
(loop while (syntax-word-char-p (character-at start -1))
do (character-offset start -1))
(move-point end start)
(loop while (syntax-word-char-p (character-at end 0))
do (character-offset end 1))
(go end)
word-current
(loop while (syntax-word-char-p (character-at end 0))
do (character-offset end 1))
(move-point start end)
(loop while (syntax-word-char-p (character-at start -1))
do (character-offset start -1))
(go end)
form-before
(form-offset start -1)
(move-point end start)
(form-offset end 1)
(go end)
form-current
(form-offset start 1)
(form-offset start -1)
(move-point end start)
(form-offset end 1)
(go end)
string-content
(try-skip-to-quote-backward start)
(try-skip-to-quote-forward end)
(go end)
upper-string
(character-offset start -1)
(character-offset end 1)
(go end)
list-content
(loop while (form-offset start -1))
(loop while (form-offset end 1))
(go end)
upper-form
(scan-lists start -1 1 t)
(move-point end start)
(form-offset end 1)
(go end)
end
(values start end)))
)
(define-command expand-region (p) (:universal-nil)
"Expand the marking region.
Sequentially expand to current word, current form, upper form, until
the whole buffer, by involking the command repeatly or with a prefix
argument."
(loop repeat (or p 1)
do (let* ((buffer (current-buffer))
(point (buffer-point buffer))
(mark (buffer-mark-object buffer))
(region-p (mark-active-p mark)))
(with-point ((end (if region-p (mark-point mark) point)))
(expand-region-1 point end)
(set-current-mark end)))))
;; Recommend binding
(define-key *global-keymap* "C-=" 'expand-region)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment