From 55d86eceaad2da958ee43692c71ece94dadfac72 Mon Sep 17 00:00:00 2001 From: Eitaro Fukamachi <e.arrows@gmail.com> Date: Mon, 13 Jan 2025 04:46:00 +0000 Subject: [PATCH] Add coalton-mode. --- extensions/coalton-mode/coalton-mode.lisp | 348 +++++++++++++++++++ extensions/coalton-mode/lem-coalton-mode.asd | 6 + 2 files changed, 354 insertions(+) create mode 100644 extensions/coalton-mode/coalton-mode.lisp create mode 100644 extensions/coalton-mode/lem-coalton-mode.asd diff --git a/extensions/coalton-mode/coalton-mode.lisp b/extensions/coalton-mode/coalton-mode.lisp new file mode 100644 index 000000000..32a20f357 --- /dev/null +++ b/extensions/coalton-mode/coalton-mode.lisp @@ -0,0 +1,348 @@ +(defpackage #:lem-coalton-mode + (:use #:cl + #:lem + #:lem/language-mode) + (:import-from #:lem-lisp-mode/grammar + #:wrap-symbol-names + #:symbol-boundary-begin + #:symbol-boundary-end) + (:import-from #:lem-lisp-mode/internal + #:check-connection + #:connected-p + #:lisp-eval-async + #:compilation-finished + #:top-of-defun-with-annotation + #:before-compile-functions) + (:import-from #:lem-lisp-syntax.indent + #:calc-function-indent + #:quote-form-point-p + #:vector-form-point-p + #:compute-indent-method + #:default-indent) + (:import-from #:alexandria + #:when-let + #:if-let) + (:export #:coalton-mode)) +(in-package #:lem-coalton-mode) + +(defparameter *body-indent* 2) +(defparameter *max-depth* 4) + +(defun make-tmlanguage-coalton () + (let ((patterns (make-tm-patterns + (make-tm-region + `(:sequence ";") + "$" + :name 'syntax-comment-attribute) + (make-tm-region + `(:sequence "#|") + `(:sequence "|#") + :patterns 'syntax-comment-attribute) + (make-tm-region + `(:sequence "|") + `(:sequence "|") + :patterns (make-tm-patterns + (make-tm-match "\\\\."))) + (make-tm-region + `(:sequence "\"") + `(:sequence "\"") + :name 'syntax-string-attribute + :patterns (make-tm-patterns + (make-tm-match "\\\\."))) + (make-tm-match + `(:sequence + "(" + ,(wrap-symbol-names "define") + "(" + (: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 "define") + (: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 + "fn" + "λ" + "match" + "let" + "lisp" + "return" + "the" + "while" + "while-let" + "loop" + "break" + "continue" + "for" + "in" + "if" + "when" + "unless" + "and" + "or" + "cond" + "as" + "do" + "progn" + "assert")) + :captures (vector nil + (make-tm-name 'syntax-keyword-attribute))) + (make-tm-match + `(:sequence + "(" + ,(wrap-symbol-names + "declare" "package" "define-type" "define-struct" "define-class" "define-instance") + (: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 + ":" + symbol + symbol-boundary-end) + :name 'syntax-builtin-attribute) + (make-tm-match + `(:sequence + symbol-boundary-begin + ,(ppcre:parse-string "[A-Z]") symbol + symbol-boundary-end) + :name 'syntax-type-attribute)))) + (make-tmlanguage :patterns patterns))) + +(defvar *syntax-table* + (make-syntax-table + :space-chars '(#\space #\tab #\newline) + :symbol-chars '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~ + #\+ #\- #\. #\@) + :paren-pairs '((#\( . #\)) + (#\[ . #\]) + (#\{ . #\})) + :string-quote-chars '(#\") + :escape-chars '(#\\) + :fence-chars '(#\|) + :expr-prefix-chars '(#\' #\, #\@ #\# #\`) + ;:expr-prefix-forward-function 'skip-expr-prefix-forward + ;:expr-prefix-backward-function 'skip-expr-prefix-backward + :line-comment-string ";" + :block-comment-pairs '(("#|" . "|#")))) + +(defvar *static-indent-table* (make-hash-table :test 'equal)) +(defvar *dynamic-indent-table* (make-hash-table :test 'equal)) + +(defun get-indentation (name) + (or (gethash name *static-indent-table*) + (caar (gethash name *dynamic-indent-table*)))) + +(defun set-indentation (name method) + (setf (gethash name *static-indent-table*) method)) + +(defparameter *coalton-indentation-rules* + '(("fn" (&lambda &body)) + ("λ" . "lambda") + ("cond" (&rest (&whole 2 &rest 1))) + ("match" (4 &rest (&whole 2 &rest 1))) + ("let" ((&whole 4 &rest (&whole 1 2)) &body)) + ("lisp" 1) + ("return" 0) + ("when" 1) + ("unless" 1) + ("while" 1) + ("while-let" . "let") + ("progn" (&rest &body)) + ("package" (4 &rest (&whole 2 &rest coalton-package-body))))) + +(defun coalton-package-body (path indent-point sexp-column) + (declare (ignore path sexp-column)) + (calc-function-indent indent-point)) + +(defun load-static-indentation-rules () + (loop for (fn . rule) in *coalton-indentation-rules* + do (set-indentation fn (etypecase rule + (string (get-indentation rule)) + (cons (first rule)))))) + +(defun find-indent-method (name path) + (flet ((f (method) + (when method + (return-from find-indent-method method)))) + (f (get-indentation name)) + (let ((name1 (ppcre:scan-to-strings "(?<=:)[^:]+" name))) + (when name1 + (f (get-indentation name1))) + (f (and (null (cdr path)) + (ppcre:scan "^(?:with-|without-|within-|do-|def)" (or name1 name)) + '(&lambda &body)))))) + +(defun calc-indent-1 (indent-point) + (let* ((const-flag nil) + (innermost-sexp-column nil) + (calculated + (with-point ((p indent-point)) + (loop + :named outer + :with path := '() :and sexp-column + :for innermost := t :then nil + :repeat *max-depth* + :do + (loop :for n :from 0 :do + (when (and (< 0 n) (start-line-p p)) + (return-from outer nil)) + (unless (form-offset p -1) + (push n path) + (return))) + (when (and (null (cdr path)) + (= 0 (car path)) + (scan-lists p -1 1 t)) + (return-from outer (1+ (point-column p)))) + (when (and innermost + (or (member (character-at p 0) '(#\: #\")) + (looking-at p "#!?[+-]"))) + (setf const-flag t)) + (let ((name (string-downcase (symbol-string-at-point p)))) + (unless (scan-lists p -1 1 t) + (return-from outer 'default-indent)) + (unless sexp-column (setf sexp-column (point-column p))) + (when innermost + (setf innermost-sexp-column sexp-column)) + (when (or (quote-form-point-p p) + (vector-form-point-p p)) + (return-from outer (1+ sexp-column))) + (let ((method (find-indent-method name path))) + (when method + (return-from outer + (cond ((eq method 'default-indent) + (setq const-flag nil) ; for the case of (:and ...) in sxql + method) + (t + (compute-indent-method method + path + indent-point + sexp-column))))))))))) + (cond ((and (eq calculated 'default-indent) + (not const-flag)) + (calc-function-indent indent-point)) + ((and (or (null calculated) + (eq calculated 'default-indent)) + const-flag) + (1+ innermost-sexp-column)) + (calculated + (if (eq calculated 'default-indent) + (calc-function-indent indent-point) + calculated)) + (t + (calc-function-indent indent-point))))) + +(defun calc-indent (point) + (line-start point) + (with-point-syntax point + (let ((state (syntax-ppss point))) + (cond + ((pps-state-string-p state) nil) + ((zerop (pps-state-paren-depth state)) + 0) + (t (calc-indent-1 point)))))) + +(define-major-mode coalton-mode language-mode + (:name "Coalton" + :keymap *coalton-mode-keymap* + :syntax-table *syntax-table* + :mode-hook *coalton-mode-hook*) + (setf (variable-value 'enable-syntax-highlight) t + (variable-value 'calc-indent-function) 'calc-indent + (variable-value 'indent-tabs-mode) nil + (variable-value 'tab-width) 4 + (variable-value 'line-comment) ";" + (variable-value 'insertion-line-comment) ";; " + (variable-value 'language-mode-tag) 'coalton-mode + (variable-value 'idle-function) 'coalton-idle-function) + (set-syntax-parser *syntax-table* (make-tmlanguage-coalton))) + +(defun guess-current-position-package (point) + (with-point ((p point)) + (loop + (ppcre:register-groups-bind (package-name) + ("^\\s*\\(\\s*package ([^\)\(\\s]*)" + (string-downcase (line-string p))) + (return package-name)) + (unless (line-offset p -1) + (return))))) + +(defun update-buffer-package () + (when-let ((package-name (guess-current-position-package (current-point)))) + (setf (buffer-package (current-buffer)) package-name))) + +(defun coalton-idle-function () + (when (connected-p) + (let ((major-mode (buffer-major-mode (current-buffer)))) + (when (eq major-mode 'coalton-mode) + (update-buffer-package))))) + +(defun buffer-package (buffer &optional default) + (let ((package-name (buffer-value buffer "package" default))) + (typecase package-name + (null (if-let (package-name (guess-current-position-package (buffer-point buffer))) + (string-upcase package-name) + default)) + ((or symbol string) + (string-upcase package-name)) + ((cons (or symbol string)) + (string-upcase (car package-name)))))) + +(defun (setf buffer-package) (package buffer) + (setf (buffer-value buffer "package") package)) + +(defvar *current-package* nil) + +(defun current-package () + (or *current-package* + (buffer-package (current-buffer)) + "COALTON-USER")) + +(defun coalton-eval-async (form &optional cont (package (current-package))) + (destructuring-bind (fn coalton-form &rest args) form + (lisp-eval-async `(,fn ,(format nil "(coalton:coalton-toplevel ~A)" coalton-form) ,@args) + cont + package))) + +(define-command coalton-compile-region (start end) (:region) + (check-connection) + (let ((string (points-to-string start end)) + (position `((:position ,(position-at-point start)) + (:line + ,(line-number-at-point (current-point)) + ,(point-charpos (current-point)))))) + (run-hooks (variable-value 'before-compile-functions) start end) + (coalton-eval-async `(micros:compile-string-for-emacs ,string + ,(buffer-name (current-buffer)) + ',position + ,(buffer-filename (current-buffer)) + nil) + #'compilation-finished))) + +(define-command coalton-compile-defun () () + (check-connection) + (with-point ((point (current-point))) + (top-of-defun-with-annotation point) + (with-point ((start point) + (end point)) + (scan-lists end 1 0) + (coalton-compile-region start end)))) + +(define-key *coalton-mode-keymap* "C-c C-c" 'coalton-compile-defun) + +(load-static-indentation-rules) +(define-file-type ("coal") coalton-mode) + +(defmethod execute :after ((mode coalton-mode) (command self-insert) argument) + (when (eql #\space (get-self-insert-char)) + (lem-lisp-mode/autodoc:lisp-autodoc))) diff --git a/extensions/coalton-mode/lem-coalton-mode.asd b/extensions/coalton-mode/lem-coalton-mode.asd new file mode 100644 index 000000000..b8fee52cc --- /dev/null +++ b/extensions/coalton-mode/lem-coalton-mode.asd @@ -0,0 +1,6 @@ +(defsystem "lem-coalton-mode" + :depends-on ("lem" + "lem-lisp-mode" + "micros") + :components + ((:file "coalton-mode")))