├── .gitignore ├── lem-base ├── package.lisp ├── documentation.lisp ├── hooks.lisp ├── errors.lisp ├── util.lisp ├── macros.lisp ├── indent.lisp ├── wide.lisp ├── var.lisp ├── buffers.lisp ├── point.lisp ├── file.lisp ├── line.lisp ├── search.lisp ├── buffer.lisp ├── buffer-insert.lisp └── basic.lisp ├── .gitmodules ├── cl-lsp.lem-lisp-syntax.asd ├── README.md ├── main.lisp ├── cl-lsp.lem-base.asd ├── cl-lsp.asd ├── roswell └── cl-lsp.ros ├── LICENSE ├── logger.lisp ├── swank.lisp ├── gray-streams.lisp ├── formatting.lisp ├── lem-lisp-syntax ├── enclosing.lisp ├── syntax-table.lisp └── indent.lisp ├── protocol-util.lisp ├── slime.lisp ├── eval.lisp ├── protocol.lisp └── server.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | -------------------------------------------------------------------------------- /lem-base/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-lsp.lem-base 2 | (:use :cl)) 3 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "vendor/linedit"] 2 | path = vendor/linedit 3 | url = https://github.com/ailisp/linedit.git 4 | [submodule "vendor/prepl"] 5 | path = vendor/prepl 6 | url = https://github.com/ailisp/prepl.git 7 | -------------------------------------------------------------------------------- /lem-base/documentation.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-lsp.lem-base) 2 | 3 | (defparameter *language* :jp) 4 | 5 | (annot:defannotation lang (form) 6 | (:inline t) 7 | (let ((string (getf form *language*))) 8 | string)) 9 | -------------------------------------------------------------------------------- /cl-lsp.lem-lisp-syntax.asd: -------------------------------------------------------------------------------- 1 | (defsystem "cl-lsp.lem-lisp-syntax" 2 | :depends-on ("cl-lsp.lem-base" "cl-ppcre") 3 | :pathname "lem-lisp-syntax/" 4 | :serial t 5 | :components ((:file "indent") 6 | (:file "syntax-table") 7 | (:file "enclosing"))) 8 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # cl-lsp 2 | An implementation of the Language Server Protocol for Common Lisp 3 | 4 | # Installation 5 | * Install [roswell](https://github.com/roswell/roswell/) 6 | * `ros install ailisp/linedit` 7 | * `ros install ailisp/prepl` 8 | * `ros install ailisp/cl-lsp` 9 | 10 | # VS Code 11 | 12 | Use [commonlisp-vscode](https://marketplace.visualstudio.com/items?itemName=ailisp.commonlisp-vscode) 13 | -------------------------------------------------------------------------------- /main.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-lsp/main 2 | (:use :cl 3 | :cl-lsp/server 4 | :cl-lsp/logger 5 | :cl-lsp/eval) 6 | (:export :run-tcp-mode 7 | :run-stdio-mode)) 8 | (in-package :cl-lsp/main) 9 | 10 | (defun run-tcp-mode (&key (port 10003)) 11 | (with-open-stream (*error-output* (make-broadcast-stream)) 12 | (with-log-file ("~/lsp-log") 13 | (log-format "server-listen~%mode:tcp~%port:~D~%" port) 14 | (jsonrpc:server-listen *server* :port port :mode :tcp)))) 15 | 16 | (defun run-stdio-mode () 17 | (with-log-file ("~/lsp-log") 18 | (log-format "server-listen~%mode:stdio~%") 19 | (jsonrpc:server-listen *server* :mode :stdio))) 20 | -------------------------------------------------------------------------------- /lem-base/hooks.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-lsp.lem-base) 2 | 3 | (export '(run-hooks add-hook remove-hook)) 4 | 5 | (defun run-hooks (hooks &rest args) 6 | (dolist (hook hooks) 7 | (apply (car hook) args))) 8 | 9 | (defmacro add-hook (place callback &optional (weight 0)) 10 | (let ((_callback (gensym))) 11 | `(let ((,_callback ,callback)) 12 | (unless (member ,_callback ,place :key #'car) 13 | (setf ,place 14 | (merge 'list 15 | (list (cons ,_callback ,weight)) 16 | ,place 17 | #'> 18 | :key #'cdr)))))) 19 | 20 | (defmacro remove-hook (place callback) 21 | `(setf ,place (delete ,callback ,place :key #'car))) 22 | -------------------------------------------------------------------------------- /cl-lsp.lem-base.asd: -------------------------------------------------------------------------------- 1 | (defsystem "cl-lsp.lem-base" 2 | :depends-on ("uiop" 3 | "iterate" 4 | "alexandria" 5 | "cl-ppcre" 6 | "cl-annot") 7 | :pathname "lem-base/" 8 | :serial t 9 | :components ((:file "package") 10 | (:file "documentation") 11 | (:file "util") 12 | (:file "errors") 13 | (:file "var") 14 | (:file "wide") 15 | (:file "macros") 16 | (:file "hooks") 17 | (:file "line") 18 | (:file "buffer") 19 | (:file "buffer-insert") 20 | (:file "buffers") 21 | (:file "point") 22 | (:file "basic") 23 | (:file "syntax") 24 | (:file "file") 25 | (:file "search") 26 | (:file "indent"))) 27 | -------------------------------------------------------------------------------- /lem-base/errors.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-lsp.lem-base) 2 | 3 | (export '(editor-condition 4 | read-only-error 5 | editor-error 6 | editor-error-message 7 | scan-error)) 8 | 9 | (define-condition editor-condition (simple-error) 10 | ()) 11 | 12 | (define-condition read-only-error (editor-condition) 13 | () 14 | (:report (lambda (condition stream) 15 | (declare (ignore condition)) 16 | (princ "Read Only" stream)))) 17 | 18 | (define-condition editor-error (editor-condition) 19 | ((message 20 | :initform "" 21 | :initarg :message 22 | :reader editor-error-message)) 23 | (:report 24 | (lambda (condition stream) 25 | (princ (editor-error-message condition) stream)))) 26 | 27 | (defun editor-error (message &rest args) 28 | (error 'editor-error :message (apply #'format nil message args))) 29 | 30 | (defun scan-error () 31 | (editor-error "Scan Error")) 32 | -------------------------------------------------------------------------------- /cl-lsp.asd: -------------------------------------------------------------------------------- 1 | (load-asd (merge-pathnames "cl-lsp.lem-base.asd" *load-pathname*)) 2 | (load-asd (merge-pathnames "cl-lsp.lem-lisp-syntax.asd" *load-pathname*)) 3 | 4 | (defsystem "cl-lsp" 5 | :depends-on ("bordeaux-threads" 6 | "trivial-gray-streams" 7 | "swank" 8 | "cl-ppcre" 9 | "optima" 10 | "alexandria" 11 | "trivial-types" 12 | "closer-mop" 13 | "quri" 14 | "jsonrpc" 15 | "yason" 16 | "cl-lsp.lem-base" 17 | "cl-lsp.lem-lisp-syntax") 18 | :serial t 19 | :components ((:file "logger") 20 | (:file "gray-streams") 21 | (:file "swank") 22 | (:file "slime") 23 | (:file "protocol") 24 | (:file "protocol-util") 25 | (:file "formatting") 26 | (:file "server") 27 | (:file "eval") 28 | (:file "main"))) 29 | -------------------------------------------------------------------------------- /roswell/cl-lsp.ros: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #|-*- mode:lisp -*-|# 3 | #| 4 | exec ros -Q -- $0 "$@" 5 | |# 6 | (progn ;;init forms 7 | (ros:ensure-asdf) 8 | #+quicklisp (ql:quickload '(:cl-lsp :prepl :linedit) :silent t) 9 | ) 10 | 11 | (defpackage :ros.script.server.3694408704 12 | (:use :cl)) 13 | (in-package :ros.script.server.3694408704) 14 | 15 | (defun main (&rest argv) 16 | (let ((mode (or (first argv) "tcp"))) 17 | (cond ((equal mode "tcp") 18 | (let ((port (second argv))) 19 | (if port 20 | (bt:make-thread (lambda () (cl-lsp/main:run-tcp-mode :port (parse-integer port)))) 21 | (bt:make-thread (lambda () (cl-lsp/main:run-tcp-mode)))) 22 | (in-package :cl-user) 23 | (prepl:repl :nobanner t :linedit t))) 24 | ((equal mode "stdio") 25 | (cl-lsp/main:run-stdio-mode)) 26 | (t 27 | (uiop:println (format nil "unknown mode: ~A" mode)) 28 | (uiop:quit 1))))) 29 | 30 | ;;; vim: set ft=lisp lisp: 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 cxxxr 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /lem-base/util.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-lsp.lem-base) 2 | 3 | (export '(pdebug 4 | utf8-bytes 5 | bests-if 6 | max-if 7 | min-if)) 8 | 9 | (defun pdebug (x &optional (file "DEBUG")) 10 | (with-open-file (out file 11 | :direction :output 12 | :if-exists :append 13 | :if-does-not-exist :create) 14 | (print x out))) 15 | 16 | (defun utf8-bytes (c) 17 | (cond 18 | ((<= c #x7f) 1) 19 | ((<= #xc2 c #xdf) 2) 20 | ((<= #xe0 c #xef) 3) 21 | ((<= #xf0 c #xf4) 4) 22 | (t 1))) 23 | 24 | (defun bests-if (fn list test) 25 | (let ((best-value) 26 | (bests)) 27 | (dolist (x list) 28 | (let ((score (funcall fn x))) 29 | (cond ((or (not best-value) 30 | (funcall test score best-value)) 31 | (setq best-value score) 32 | (setq bests (list x))) 33 | ((= best-value score) 34 | (push x bests))))) 35 | (values bests best-value))) 36 | 37 | (defun max-if (fn list) 38 | (bests-if fn list #'>)) 39 | 40 | (defun min-if (fn list) 41 | (bests-if fn list #'<)) 42 | -------------------------------------------------------------------------------- /logger.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-lsp/logger 2 | (:use :cl) 3 | (:export :*enable-logger* 4 | :*logger-stream* 5 | :log-format 6 | :with-log-file 7 | :with-log-stream)) 8 | (in-package :cl-lsp/logger) 9 | 10 | (defvar *enable-logger* nil) 11 | (defvar *logger-stream*) 12 | 13 | (let ((lock (bt:make-lock))) 14 | (defun log-format (string &rest args) 15 | (bt:with-lock-held (lock) 16 | (when (boundp '*logger-stream*) 17 | (apply #'format *logger-stream* string args) 18 | (force-output *logger-stream*))))) 19 | 20 | (defun call-with-log-file (file function) 21 | (if *enable-logger* 22 | (let ((stream (open file 23 | :direction :output 24 | :if-does-not-exist :create 25 | :if-exists :append))) 26 | (setf *logger-stream* stream) 27 | (unwind-protect (funcall function) 28 | (close stream))) 29 | (funcall function))) 30 | 31 | (defmacro with-log-file ((file) &body body) 32 | `(call-with-log-file ,file (lambda () ,@body))) 33 | 34 | (defmacro with-log-stream ((stream) &body body) 35 | `(if *enable-logger* 36 | (let ((*logger-stream* ,stream)) 37 | ,@body) 38 | (progn ,@body))) 39 | -------------------------------------------------------------------------------- /lem-base/macros.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-lsp.lem-base) 2 | 3 | (annot:enable-annot-syntax) 4 | 5 | (export '(save-excursion 6 | with-point 7 | with-buffer-read-only 8 | without-interrupts)) 9 | 10 | (defmacro save-excursion (&body body) 11 | @lang(:jp "現在の`point`と`mark`を保存し、`body`の評価後に復元し`body`の結果を返します。 12 | `body`でエラーがあっても復元されます。") 13 | `(invoke-save-excursion (lambda () ,@body))) 14 | 15 | (defmacro with-point (bindings &body body) 16 | @lang(:jp "このマクロは`body`内で使う各`point`を`bindings`で作り、 17 | `body`を抜けると各`point`を削除して`body`の値を返します。 18 | `body`でエラーがあっても各`point`は削除されます。 19 | `bindings`の形式は(`var` `point` &optional `kind`)のリストです。 20 | `kind`は省略可能でデフォルトで`:temporary`です。 21 | ``` 22 | 例 23 | \(with-point ((p3 expr1) 24 | (p1 expr2 :left-inserting) 25 | (p2 expr3 :right-inserting)) 26 | ...) 27 | ``` 28 | ") 29 | (let ((cleanups 30 | (mapcan (lambda (b) 31 | (destructuring-bind (var point &optional (kind :temporary)) b 32 | (declare (ignore point)) 33 | (unless (eq :temporary kind) 34 | `((delete-point ,var))))) 35 | bindings))) 36 | `(let ,(mapcar (lambda (b) 37 | (destructuring-bind (var point &optional (kind :temporary)) b 38 | `(,var (copy-point ,point ,kind)))) 39 | bindings) 40 | ,(if cleanups 41 | `(unwind-protect (progn ,@body) 42 | ,@cleanups) 43 | `(progn ,@body))))) 44 | 45 | (defmacro with-buffer-read-only (buffer flag &body body) 46 | (let ((gbuffer (gensym "BUFFER")) 47 | (gtmp (gensym "GTMP"))) 48 | `(let* ((,gbuffer ,buffer) 49 | (,gtmp (buffer-read-only-p ,gbuffer))) 50 | (setf (buffer-read-only-p ,gbuffer) ,flag) 51 | (unwind-protect (progn ,@body) 52 | (setf (buffer-read-only-p ,gbuffer) ,gtmp))))) 53 | 54 | (defmacro without-interrupts (&body body) 55 | `(#+ccl ccl:without-interrupts 56 | #+sbcl sb-sys:without-interrupts 57 | #-(or ccl sbcl) progn 58 | ,@body)) 59 | -------------------------------------------------------------------------------- /swank.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-lsp/swank 2 | (:use :cl) 3 | (:export :swank-init 4 | :fuzzy-completions 5 | :describe-symbol 6 | :xrefs 7 | :operator-arglist 8 | :find-definitions 9 | :swank-apropos-list 10 | :swank-compile-file)) 11 | (in-package :cl-lsp/swank) 12 | 13 | (defvar *fuzzy-completions* nil) 14 | 15 | (defmacro with-swank ((&key (package (find-package "CL-USER")) 16 | (readtable '*readtable*)) 17 | &body body) 18 | `(let ((swank::*buffer-package* ,package) 19 | (swank::*buffer-readtable* ,readtable)) 20 | ,@body)) 21 | 22 | (defun swank-init () 23 | (swank:swank-require '("SWANK-TRACE-DIALOG" 24 | "SWANK-PACKAGE-FU" 25 | "SWANK-PRESENTATIONS" 26 | "SWANK-FUZZY" 27 | "SWANK-FANCY-INSPECTOR" 28 | "SWANK-C-P-C" 29 | "SWANK-ARGLISTS" 30 | "SWANK-REPL")) 31 | (setf *fuzzy-completions* (intern "FUZZY-COMPLETIONS" :SWANK)) 32 | (values)) 33 | 34 | (defun fuzzy-completions (string package) 35 | (with-swank () 36 | (funcall *fuzzy-completions* 37 | string package))) 38 | 39 | (defun describe-symbol (symbol-name package) 40 | (ignore-errors 41 | (with-swank (:package package) 42 | (swank:describe-symbol symbol-name)))) 43 | 44 | (defun xrefs (name package) 45 | (with-swank (:package package) 46 | (swank:xrefs '(:calls :macroexpands :binds :references :sets :specializes) 47 | name))) 48 | 49 | (defun operator-arglist (symbol-string package) 50 | (swank:operator-arglist symbol-string package)) 51 | 52 | (defun find-definitions (name package) 53 | (multiple-value-bind (symbol found) 54 | (with-swank (:package package) 55 | (swank::find-definitions-find-symbol-or-package name)) 56 | (when found 57 | (ignore-errors (swank::find-definitions symbol))))) 58 | 59 | (defun swank-apropos-list (name package) 60 | (with-swank (:package package) 61 | (mapcar #'cadr (swank:apropos-list-for-emacs name)))) 62 | 63 | (defun swank-compile-file (filename loadp) 64 | (with-swank () 65 | (swank:compile-file-for-emacs filename loadp))) 66 | -------------------------------------------------------------------------------- /lem-base/indent.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-lsp.lem-base) 2 | 3 | (export '(back-to-indentation 4 | indent-line 5 | indent-tabs-mode 6 | calc-indent-function)) 7 | 8 | (define-editor-variable indent-tabs-mode nil) 9 | (define-editor-variable calc-indent-function 'calc-indent-default) 10 | 11 | (defun back-to-indentation (point) 12 | (skip-whitespace-forward (line-start point) t) 13 | point) 14 | 15 | (defun indent-line-1 (point column) 16 | (when (null column) 17 | (return-from indent-line-1 t)) 18 | (when (minusp column) 19 | (setf column 0)) 20 | (let ((old-column (point-column point)) 21 | (old-indent-string 22 | (with-point ((start point) 23 | (end point)) 24 | (points-to-string (line-start start) 25 | (back-to-indentation end)))) 26 | (new-indent-string 27 | (if (variable-value 'indent-tabs-mode :buffer point) 28 | (multiple-value-bind (div mod) 29 | (floor column (tab-size)) 30 | (concatenate 'string 31 | (make-string div :initial-element #\tab) 32 | (make-string mod :initial-element #\space))) 33 | (make-string column :initial-element #\space)))) 34 | (cond ((string/= old-indent-string new-indent-string) 35 | (line-start point) 36 | (delete-character point (length old-indent-string)) 37 | (insert-string point new-indent-string) 38 | (if (< old-column column) 39 | (back-to-indentation point) 40 | (move-to-column point 41 | (max 0 (+ old-column 42 | (- (string-width new-indent-string) 43 | (string-width old-indent-string))))))) 44 | ((< old-column column) 45 | (back-to-indentation point)))) 46 | t) 47 | 48 | (defun calc-indent-default (point) 49 | (cond ((line-offset point -1) 50 | (back-to-indentation point) 51 | (point-column point)) 52 | (t 0))) 53 | 54 | (defun indent-line (point) 55 | (let ((column (funcall (or (variable-value 'calc-indent-function :buffer point) 56 | 'calc-indent-default) 57 | (copy-point point :temporary)))) 58 | (indent-line-1 point column))) 59 | -------------------------------------------------------------------------------- /gray-streams.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-lsp/gray-streams 2 | (:use :cl :trivial-gray-streams) 3 | (:export :lsp-output-stream)) 4 | (in-package :cl-lsp/gray-streams) 5 | 6 | (defclass lsp-output-stream (fundamental-character-output-stream) 7 | ((output-fn 8 | :initarg :output-fn 9 | :reader output-fn) 10 | (buffer 11 | :initform (make-string 8000) 12 | :reader buffer) 13 | (index 14 | :initform 0 15 | :accessor index) 16 | (column 17 | :initform 0 18 | :accessor column))) 19 | 20 | (defmethod stream-write-char ((stream lsp-output-stream) character) 21 | (setf (schar (buffer stream) (index stream)) 22 | character) 23 | (incf (index stream)) 24 | (if (char= character #\newline) 25 | (setf (column stream) 0) 26 | (incf (column stream))) 27 | (when (= (index stream) (length (buffer stream))) 28 | (stream-finish-output stream)) 29 | character) 30 | 31 | (defmethod stream-write-string ((stream lsp-output-stream) (string string) &optional start end) 32 | (let* ((start (or start 0)) 33 | (end (or end (length string))) 34 | (len (length (buffer stream))) 35 | (count (- end start)) 36 | (free (- len (index stream)))) 37 | (when (>= count free) 38 | (stream-finish-output stream)) 39 | (cond ((< count len) 40 | (replace (buffer stream) string 41 | :start1 (index stream) 42 | :start2 start :end2 end) 43 | (incf (index stream) count)) 44 | (t 45 | (funcall (output-fn stream) (subseq string start end)))) 46 | (let ((last-newline (position #\newline string 47 | :from-end t 48 | :start start :end end))) 49 | (setf (column stream) 50 | (if last-newline 51 | (- end last-newline 1) 52 | (+ (column stream) count))))) 53 | string) 54 | 55 | (defmethod stream-line-column ((stream lsp-output-stream)) 56 | (column stream)) 57 | 58 | (defmethod stream-finish-output ((stream lsp-output-stream)) 59 | (when (< 0 (index stream)) 60 | (funcall (output-fn stream) 61 | (subseq (buffer stream) 62 | 0 63 | (index stream))) 64 | (setf (index stream) 0)) 65 | nil) 66 | 67 | (defmethod stream-force-output ((stream lsp-output-stream)) 68 | (stream-finish-output stream)) 69 | 70 | (defmethod stream-fresh-line ((stream lsp-output-stream)) 71 | (cond ((zerop (column stream)) 72 | nil) 73 | (t 74 | (terpri stream) 75 | t))) 76 | -------------------------------------------------------------------------------- /formatting.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-lsp/formatting 2 | (:use :cl 3 | :cl-lsp/protocol 4 | :cl-lsp/protocol-util 5 | :cl-lsp/logger 6 | :cl-lsp.lem-base) 7 | (:import-from :cl-lsp.lem-lisp-syntax.indent 8 | :calc-indent) 9 | (:export :on-type-formatting 10 | :range-formatting 11 | :buffer-formatting)) 12 | (in-package :cl-lsp/formatting) 13 | 14 | (defun indent-line (p &optional editp) 15 | (let ((line-number (1- (line-number-at-point p))) 16 | (old-charpos (point-charpos (back-to-indentation p))) 17 | (new-column (calc-indent (copy-point p :temporary)))) 18 | (when new-column 19 | (when editp 20 | (line-start p) 21 | (delete-character p old-charpos) 22 | (insert-character p #\space new-column)) 23 | (convert-to-hash-table 24 | (make-instance '|TextEdit| 25 | :|range| (make-instance 26 | '|Range| 27 | :|start| (make-instance '|Position| 28 | :|line| line-number 29 | :|character| 0) 30 | :|end| (make-instance '|Position| 31 | :|line| line-number 32 | :|character| old-charpos)) 33 | :|newText| (make-string new-column :initial-element #\space)))))) 34 | 35 | (defun set-formatting-options (options) 36 | (setf (tab-size) (slot-value options '|tabSize|))) 37 | 38 | (defun on-type-formatting (point ch options) 39 | (declare (ignore ch)) 40 | (set-formatting-options options) 41 | (let ((edit (indent-line point))) 42 | (if edit 43 | (list edit) 44 | (vector)))) 45 | 46 | (defun range-formatting (start end options) 47 | (set-formatting-options options) 48 | (let ((buffer (point-buffer start)) 49 | (edits '())) 50 | (buffer-enable-undo buffer) 51 | (apply-region-lines start end 52 | (lambda (point) 53 | (multiple-value-bind (edit) 54 | (indent-line point t) 55 | (when edit 56 | (push edit edits))))) 57 | (buffer-undo start) 58 | (buffer-disable-undo buffer) 59 | (list-to-object[] (nreverse edits)))) 60 | 61 | (defun buffer-formatting (buffer options) 62 | (with-point ((start (buffer-start-point buffer)) 63 | (end (buffer-end-point buffer))) 64 | (range-formatting start end options))) 65 | -------------------------------------------------------------------------------- /lem-base/wide.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-lsp.lem-base) 2 | 3 | (export '(tab-size 4 | wide-char-p 5 | char-width 6 | string-width 7 | wide-index)) 8 | 9 | (defvar *tab-size* 8) 10 | 11 | (defun tab-size () 12 | *tab-size*) 13 | 14 | (defun (setf tab-size) (tab-size) 15 | (setf *tab-size* tab-size)) 16 | 17 | (eval-when (:compile-toplevel :load-toplevel :execute) 18 | (defvar *eastasian-full* 19 | (vector 20 | '(#x01100 #x0115f) '(#x02329 #x0232a) '(#x02e80 #x02e99) '(#x02e9b #x02ef3) 21 | '(#x02f00 #x02fd5) '(#x02ff0 #x02ffb) '(#x03000 #x0303e) '(#x03041 #x03096) 22 | '(#x03099 #x030ff) '(#x03105 #x0312d) '(#x03131 #x0318e) '(#x03190 #x031ba) 23 | '(#x031c0 #x031e3) '(#x031f0 #x0321e) '(#x03220 #x03247) '(#x03250 #x032fe) 24 | '(#x03300 #x04dbf) '(#x04e00 #x0a48c) '(#x0a490 #x0a4c6) '(#x0a960 #x0a97c) 25 | '(#x0ac00 #x0d7a3) '(#x0f900 #x0faff) '(#x0fe10 #x0fe19) '(#x0fe30 #x0fe52) 26 | '(#x0fe54 #x0fe66) '(#x0fe68 #x0fe6b) '(#x0ff01 #x0ff60) '(#x0ffe0 #x0ffe6) 27 | '(#x1b000 #x1b001) '(#x1f200 #x1f202) '(#x1f210 #x1f23a) '(#x1f240 #x1f248) 28 | '(#x1f250 #x1f251) '(#x20000 #x2fffd) '(#x30000 #x3fffd))) 29 | 30 | (defun gen-binary-search-function (name vector) 31 | (declare (optimize (speed 0) (safety 3) (debug 3))) 32 | (labels ((rec (begin end) 33 | (when (<= begin end) 34 | (let* ((i (floor (+ end begin) 2)) 35 | (elt (aref vector i)) 36 | (a (car elt)) 37 | (b (cadr elt)) 38 | (then (rec begin (1- i))) 39 | (else (rec (1+ i) end))) 40 | `(if (<= ,a code ,b) 41 | t 42 | ,(if (or then else) 43 | `(if (< code ,a) 44 | ,then 45 | ,else))))))) 46 | (compile 47 | (eval 48 | `(defun ,name (code) 49 | (declare (optimize (speed 3) (safety 0) (debug 0))) 50 | (declare (fixnum code)) 51 | ,(rec 0 (1- (length vector)))))))) 52 | 53 | (gen-binary-search-function '%binary-search *eastasian-full*)) 54 | 55 | (defun wide-char-p (c) 56 | (declare (character c)) 57 | (%binary-search (char-code c))) 58 | 59 | (defun char-width (c w) 60 | (declare (character c) (fixnum w)) 61 | (cond ((char= c #\tab) 62 | (+ (* (floor w (tab-size)) (tab-size)) (tab-size))) 63 | ((or (wide-char-p c) (char<= #.(code-char 0) c #.(code-char 26))) 64 | (+ w 2)) 65 | (t 66 | (+ w 1)))) 67 | 68 | (defun string-width (str &optional (start 0) end) 69 | (loop :with width := 0 70 | :for i :from start :below (or end (length str)) 71 | :for c := (aref str i) 72 | :do (setq width (char-width c width)) 73 | :finally (return width))) 74 | 75 | (defun wide-index (str goal &key (start 0)) 76 | (loop 77 | with w = 0 78 | for i from start below (length str) by 1 79 | for c across str do 80 | (setq w (char-width c w)) 81 | (when (< goal w) 82 | (return i)))) 83 | -------------------------------------------------------------------------------- /lem-lisp-syntax/enclosing.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-lsp.lem-lisp-syntax.enclosing 2 | (:use :cl :cl-lsp.lem-base) 3 | (:export :search-local-definition)) 4 | (in-package :cl-lsp.lem-lisp-syntax.enclosing) 5 | 6 | (defvar *variable-binding-ops* 7 | '(("let" &bindings 1 &body 2) 8 | ("let*" &bindings 1 &body 2))) 9 | 10 | (defvar *function-binding-ops* 11 | '(("flet" &bindings 1 &body 2) 12 | ("labels" &bindings 1 &body 1) 13 | ("macrolet" &bindings 1 &body 2))) 14 | 15 | (defun lookup-binding-op (op &optional binding-type) 16 | (labels ((lookup-in (list) (assoc op list :test #'string=))) 17 | (case binding-type 18 | ((:variable) (lookup-in *variable-binding-ops*)) 19 | ((:function) (lookup-in *function-binding-ops*)) 20 | (otherwise (or (lookup-in *variable-binding-ops*) 21 | (lookup-in *function-binding-ops*)))))) 22 | 23 | (defun binding-op-p (op &optional binding-type) 24 | (when (lookup-binding-op op binding-type) t)) 25 | 26 | (defun binding-op-body-pos (op) 27 | (let ((specs (lookup-binding-op op))) 28 | (when specs 29 | (getf (cdr specs) '&body)))) 30 | 31 | (defun binding-op-bindings-pos (op) 32 | (let ((specs (lookup-binding-op op))) 33 | (when specs 34 | (getf (cdr specs) '&bindings)))) 35 | 36 | (defun traverse-list (point function) 37 | (with-point ((p point)) 38 | (if (maybe-beginning-of-string-or-comment p) 39 | (form-offset p 1) 40 | (skip-symbol-forward p)) 41 | (loop 42 | (let ((arg-index 0)) 43 | (when (or (member (character-at p) '(#\( #\')) 44 | (syntax-space-char-p (character-at p -1))) 45 | (incf arg-index)) 46 | (form-offset p -1) 47 | (loop :while (form-offset p -1) 48 | :do (incf arg-index)) 49 | (unless (scan-lists p -1 1 t) 50 | (return)) 51 | (when (member (character-at p) '(#\( #\')) 52 | (character-offset p 1) 53 | (let ((name (symbol-string-at-point p))) 54 | (funcall function 55 | (copy-point p :temporary) 56 | name 57 | arg-index)) 58 | (scan-lists p -1 1))) 59 | (when (start-line-p p) 60 | (return))))) 61 | 62 | (defun search-local-definition (point name) 63 | (traverse-list point 64 | (lambda (p op index) 65 | (when (and (binding-op-p op) 66 | (>= index (binding-op-body-pos op))) 67 | (form-offset p (binding-op-bindings-pos op)) 68 | (scan-lists p 1 -1) 69 | (loop 70 | (unless (scan-lists p 1 -1 t) (return)) 71 | (when (equal name (symbol-string-at-point p)) 72 | (return-from search-local-definition p)) 73 | (unless (scan-lists p 1 1 t) (return))))))) 74 | -------------------------------------------------------------------------------- /protocol-util.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-lsp/protocol-util 2 | (:use :cl 3 | :cl-lsp/protocol 4 | :cl-lsp.lem-base) 5 | (:export :list-to-object-or-object[] 6 | :list-to-object[] 7 | :uri-to-filename 8 | :filename-to-uri 9 | :move-to-lsp-position 10 | :make-lsp-range 11 | :file-location 12 | :buffer-location)) 13 | (in-package :cl-lsp/protocol-util) 14 | 15 | (defun list-to-object-or-object[] (list) 16 | (cond ((null list) (vector)) 17 | ((null (cdr list)) (first list)) 18 | (t list))) 19 | 20 | (defun list-to-object[] (list) 21 | (cond ((null list) (vector)) 22 | (t list))) 23 | 24 | (defun uri-to-filename (uri) 25 | (quri:uri-path (quri:uri uri))) 26 | 27 | (defun filename-to-uri (uri) 28 | (format nil "file://~A" uri)) 29 | 30 | (defun move-to-lsp-position (point position) 31 | (declare (type point point) 32 | (type |Position| position)) 33 | (with-slots (|line| |character|) position 34 | (move-to-line point (1+ |line|)) 35 | (line-offset point 0 |character|) 36 | point)) 37 | 38 | (defun make-lsp-range (start end) 39 | (declare (type point start end)) 40 | (let* ((start-line (1- (line-number-at-point start))) 41 | (start-character (point-charpos start)) 42 | (end-line (+ start-line (count-lines start end))) 43 | (end-character (point-charpos end))) 44 | (make-instance '|Range| 45 | :|start| (make-instance '|Position| :|line| start-line :|character| start-character) 46 | :|end| (make-instance '|Position| :|line| end-line :|character| end-character)))) 47 | 48 | (defun line-location (file line start-charpos end-charpos) 49 | (make-instance 50 | '|Location| 51 | :|uri| (filename-to-uri file) 52 | :|range| (make-instance 53 | '|Range| 54 | :|start| (make-instance 55 | '|Position| 56 | :|line| line 57 | :|character| start-charpos) 58 | :|end| (make-instance 59 | '|Position| 60 | :|line| line 61 | :|character| end-charpos)))) 62 | 63 | (defun file-location (file offset) 64 | (with-open-file (in file) 65 | (loop :for string := (read-line in) 66 | :for length := (1+ (length string)) 67 | :for line :from 0 68 | :do (if (>= offset length) 69 | (decf offset length) 70 | (return (line-location file line 0 (length string))))))) 71 | 72 | (defun buffer-location (point) 73 | (let ((line (1- (line-number-at-point point)))) 74 | (line-location (buffer-filename (point-buffer point)) 75 | line 76 | (point-charpos point) 77 | (with-point ((p point)) 78 | (if (form-offset p 1) 79 | (point-charpos p) 80 | (length (line-string point))))))) 81 | -------------------------------------------------------------------------------- /lem-base/var.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-lsp.lem-base) 2 | 3 | (export '(define-editor-variable 4 | clear-editor-local-variables 5 | variable-value 6 | variable-documentation)) 7 | 8 | (defvar *editor-variables* '()) 9 | 10 | (defstruct editor-variable 11 | value 12 | documentation 13 | local-indicator) 14 | 15 | (defun clear-editor-local-variables (buffer) 16 | (dolist (symbol *editor-variables*) 17 | (buffer-unbound buffer 18 | (editor-variable-local-indicator 19 | (get symbol 'editor-variable))))) 20 | 21 | (defmacro define-editor-variable (var &optional value documentation) 22 | (check-type var symbol) 23 | `(unless (get ',var 'editor-variable) 24 | (defvar ,var) 25 | (pushnew ',var *editor-variables*) 26 | (setf (get ',var 'editor-variable) 27 | (make-editor-variable :value ,value 28 | :documentation ,documentation 29 | :local-indicator (gensym ,(string var)))) 30 | t)) 31 | 32 | (defun editor-variable-error (symbol) 33 | (error "~A is not editor variable" symbol)) 34 | 35 | (defun check-editor-variable (symbol) 36 | (unless (editor-variable-p (get symbol 'editor-variable)) 37 | (editor-variable-error symbol))) 38 | 39 | (defun ensure-buffer (where) 40 | (if (pointp where) 41 | (point-buffer where) 42 | (progn 43 | (check-type where buffer) 44 | where))) 45 | 46 | (defun variable-value (symbol &optional (kind :default) (where nil wherep)) 47 | (let ((var (get symbol 'editor-variable))) 48 | (unless (editor-variable-p var) 49 | (editor-variable-error symbol)) 50 | (ecase kind 51 | ((:default) 52 | (let ((buffer (if wherep 53 | (ensure-buffer where) 54 | (current-buffer)))) 55 | (buffer-value buffer 56 | (editor-variable-local-indicator var) 57 | (editor-variable-value var)))) 58 | ((:buffer) 59 | (let ((buffer (if wherep 60 | (ensure-buffer where) 61 | (current-buffer)))) 62 | (buffer-value buffer 63 | (editor-variable-local-indicator var)))) 64 | ((:global) 65 | (editor-variable-value var))))) 66 | 67 | (defun (setf variable-value) (value symbol &optional (kind :default) (where nil wherep)) 68 | (let ((var (get symbol 'editor-variable))) 69 | (unless (editor-variable-p var) 70 | (editor-variable-error symbol)) 71 | (ecase kind 72 | ((:default :buffer) 73 | (let ((buffer (if wherep 74 | (ensure-buffer where) 75 | (current-buffer)))) 76 | (setf (buffer-value buffer 77 | (editor-variable-local-indicator var)) 78 | value))) 79 | ((:global) 80 | (setf (editor-variable-value var) value))))) 81 | 82 | (defun variable-documentation (symbol) 83 | (let ((var (get symbol 'editor-variable))) 84 | (unless (editor-variable-p var) 85 | (editor-variable-error symbol)) 86 | (editor-variable-documentation var))) 87 | -------------------------------------------------------------------------------- /lem-base/buffers.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-lsp.lem-base) 2 | 3 | (annot:enable-annot-syntax) 4 | 5 | (export '(kill-buffer-hook 6 | buffer-list 7 | ghost-buffer-p 8 | special-buffer-p 9 | filter-special-buffers 10 | any-modified-buffer-p 11 | get-buffer 12 | get-buffer-create 13 | uniq-buffer-name 14 | update-prev-buffer 15 | bury-buffer 16 | get-next-buffer 17 | delete-buffer 18 | get-file-buffer)) 19 | 20 | (define-editor-variable kill-buffer-hook '()) 21 | 22 | (defvar *buffer-list* '()) 23 | 24 | (defun add-buffer (buffer) 25 | (check-type buffer buffer) 26 | (unless (ghost-buffer-p buffer) 27 | (assert (not (get-buffer (buffer-name buffer)))) 28 | (push buffer *buffer-list*))) 29 | 30 | (defun buffer-list () 31 | @lang(:jp "`buffer`のリストを返します。") 32 | *buffer-list*) 33 | 34 | (defun ghost-buffer-p (buffer) 35 | (let ((name (buffer-name buffer))) 36 | (and (<= 3 (length name)) 37 | (char= #\space (aref name 0)) 38 | (char= #\* (aref name 1)) 39 | (char= #\* (aref name (1- (length name))))))) 40 | 41 | (defun special-buffer-p (buffer) 42 | (or (ghost-buffer-p buffer) 43 | (let ((name (buffer-name buffer))) 44 | (and (char= #\* (aref name 0)) 45 | (char= #\* (aref name (1- (length name)))))))) 46 | 47 | (defun filter-special-buffers () 48 | (remove-if #'special-buffer-p (buffer-list))) 49 | 50 | (defun any-modified-buffer-p () 51 | (find-if #'(lambda (buffer) 52 | (and (buffer-filename buffer) 53 | (buffer-modified-p buffer))) 54 | (filter-special-buffers))) 55 | 56 | (defun get-buffer (buffer-or-name) 57 | @lang(:jp "`buffer-or-name`がバッファならそのまま返し、 58 | 文字列ならその名前のバッファを返します。") 59 | (if (bufferp buffer-or-name) 60 | buffer-or-name 61 | (find-if #'(lambda (buffer) 62 | (string= buffer-or-name 63 | (buffer-name buffer))) 64 | (buffer-list)))) 65 | 66 | (defun get-buffer-create (name) 67 | @lang(:jp "バッファ名`name`のバッファがあればそれを返し、 68 | 無ければ作って返します。") 69 | (or (get-buffer name) 70 | (make-buffer name))) 71 | 72 | (defun uniq-buffer-name (name) 73 | (if (null (get-buffer name)) 74 | name 75 | (do ((n 1 (1+ n))) (nil) 76 | (let ((name (format nil "~a<~d>" name n))) 77 | (unless (get-buffer name) 78 | (return name)))))) 79 | 80 | (defun update-prev-buffer (buffer) 81 | (check-type buffer buffer) 82 | (setq *buffer-list* 83 | (cons buffer 84 | (remove buffer (buffer-list))))) 85 | 86 | (defun delete-buffer (buffer) 87 | @lang(:jp "`buffer`をバッファのリストから消します。 88 | エディタ変数`kill-buffer-hook`がバッファが消される前に実行されます。") 89 | (check-type buffer buffer) 90 | (alexandria:when-let ((hooks (variable-value 'kill-buffer-hook :buffer buffer))) 91 | (run-hooks hooks buffer)) 92 | (alexandria:when-let ((hooks (variable-value 'kill-buffer-hook :global))) 93 | (run-hooks hooks buffer)) 94 | (buffer-free buffer) 95 | (setf *buffer-list* (delete buffer (buffer-list)))) 96 | 97 | (defun get-next-buffer (buffer) 98 | @lang(:jp "バッファリスト内にある`buffer`の次のバッファを返します。") 99 | (check-type buffer buffer) 100 | (let* ((buffer-list (reverse (buffer-list))) 101 | (res (member buffer buffer-list))) 102 | (if (cdr res) 103 | (cadr res) 104 | (car buffer-list)))) 105 | 106 | (defun bury-buffer (buffer) 107 | @lang(:jp "`buffer`をバッファリストの一番最後に移動させ、バッファリストの先頭を返します。") 108 | (check-type buffer buffer) 109 | (setf *buffer-list* 110 | (append (remove buffer (buffer-list)) 111 | (list buffer))) 112 | (car (buffer-list))) 113 | 114 | (defun get-file-buffer (filename) 115 | @lang(:jp "`filename`に対応するバッファを返します。 116 | 見つからなければNILを返します。") 117 | (dolist (buffer (buffer-list)) 118 | (when (uiop:pathname-equal filename (buffer-filename buffer)) 119 | (return buffer)))) 120 | -------------------------------------------------------------------------------- /slime.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-lsp/slime 2 | (:use :cl 3 | :cl-lsp.lem-base) 4 | (:export :symbol-string-at-point* 5 | :beginning-of-defun-point 6 | :beginning-of-defun 7 | :form-string 8 | :map-buffer-symbols 9 | :search-buffer-package 10 | :compilation-notes)) 11 | (in-package :cl-lsp/slime) 12 | 13 | (defun symbol-string-at-point* (point) 14 | (let ((string (symbol-string-at-point point))) 15 | (when string 16 | (values (ppcre:regex-replace "^(?:#\\.|,@)" string ""))))) 17 | 18 | (defun beginning-of-defun-point (point n) 19 | (with-point ((curr point)) 20 | (if (minusp n) 21 | (dotimes (_ (- n) curr) 22 | (if (start-line-p curr) 23 | (line-offset curr -1) 24 | (line-start curr)) 25 | (loop 26 | (when (char= #\( (character-at curr 0)) 27 | (return)) 28 | (unless (line-offset curr -1) 29 | (return-from beginning-of-defun-point curr)))) 30 | (dotimes (_ n curr) 31 | (loop 32 | (unless (line-offset curr 1) 33 | (return-from beginning-of-defun-point curr)) 34 | (when (char= #\( (character-at curr 0)) 35 | (return))))))) 36 | 37 | (defun beginning-of-defun (point n) 38 | (move-point point (beginning-of-defun-point point n))) 39 | 40 | (defun form-string (point) 41 | (if (and (start-line-p point) 42 | (eql #\( (character-at point))) 43 | (with-point ((p point)) 44 | (when (form-offset p 1) 45 | (points-to-string point p))) 46 | (with-point ((p point)) 47 | (when (form-offset p -1) 48 | (points-to-string p point))))) 49 | 50 | (defun map-buffer-symbols (buffer function) 51 | (with-point ((p (buffer-start-point buffer))) 52 | (loop 53 | (loop 54 | (when (= 0 (skip-chars-forward p 55 | (complement 56 | (lambda (c) 57 | (or (member c '(#\, #\' #\`)) 58 | (syntax-symbol-char-p c)))))) 59 | (return-from map-buffer-symbols)) 60 | (alexandria:if-let ((str (looking-at p ",@|,|'|`|#\\."))) 61 | (character-offset p (length str)) 62 | (return))) 63 | (cond 64 | ((maybe-beginning-of-string-or-comment p) 65 | (unless (form-offset p 1) (return))) 66 | (t 67 | (with-point ((start p)) 68 | (form-offset p 1) 69 | (funcall function (points-to-string start p)))))))) 70 | 71 | (defun search-buffer-package (point) 72 | (with-point ((p point)) 73 | (buffer-start p) 74 | (or (loop :while (search-forward-regexp p "^\\s*\\(in-package\\s") 75 | :do (with-point ((start p)) 76 | (when (form-offset p 1) 77 | (handler-case (let ((name (symbol-name 78 | (read-from-string 79 | (points-to-string start p))))) 80 | (unless (equal name "CL-USER") 81 | (return (find-package name)))) 82 | (error () 83 | (find-package "CL-USER")))))) 84 | (find-package "CL-USER")))) 85 | 86 | (defun compilation-notes (notes function) 87 | (dolist (note notes) 88 | (optima:match note 89 | ((and (optima:property :location 90 | (or (list :location 91 | (list :buffer buffer-name) 92 | (list :offset pos _) 93 | _) 94 | (list :location 95 | (list :file file) 96 | (list :position pos) 97 | _))) 98 | (or (optima:property :message message) (and)) 99 | (or (optima:property :severity severity) (and)) 100 | (or (optima:property :source-context _source-context) (and))) 101 | (let* ((buffer (if buffer-name 102 | (get-buffer buffer-name) 103 | (get-file-buffer file))) 104 | (point (buffer-point buffer))) 105 | (move-to-position point pos) 106 | (skip-chars-backward point #'syntax-symbol-char-p) 107 | (with-point ((end point)) 108 | (unless (form-offset end 1) 109 | (when (eq severity :read-error) 110 | (buffer-start point)) 111 | (buffer-end end)) 112 | (funcall function point end severity message))))))) 113 | -------------------------------------------------------------------------------- /lem-base/point.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-lsp.lem-base) 2 | 3 | (annot:enable-annot-syntax) 4 | 5 | (export '(current-point 6 | point 7 | pointp 8 | copy-point 9 | delete-point 10 | point-buffer 11 | point-charpos 12 | point-kind 13 | point= 14 | point/= 15 | point< 16 | point<= 17 | point> 18 | point>=)) 19 | 20 | (defclass point () 21 | ((buffer 22 | :initarg :buffer 23 | :reader point-buffer 24 | :type buffer) 25 | (linum 26 | :initarg :linum 27 | :accessor point-linum 28 | :type fixnum) 29 | (line 30 | :initarg :line 31 | :accessor point-line 32 | :type line) 33 | (charpos 34 | :initarg :charpos 35 | :accessor point-charpos 36 | :type fixnum) 37 | (kind 38 | :initarg :kind 39 | :reader point-kind 40 | :type (member :temporary :left-inserting :right-inserting))) 41 | (:documentation 42 | @lang(:jp "`point`はバッファ内のテキストの位置を指すオブジェクトです。 43 | `buffer`とその位置の行、行頭からの0始まりのオフセット`charpos`をもっています。 44 | `point`には`kind`があり、バッファ内に挿入、削除した後の位置が`kind`の値によって変わります。 45 | `kind`が`:temporary`の時は`point`を一時的な読み取りに使います。 46 | 作成、削除時のオーバーヘッドが低く、明示的に削除する必要もありませんが、 47 | その位置より前を編集した後はその`point`は正しく使用できません。 48 | `kind`が`:left-inserting`または`:right-inserting`の時はそれより前の位置を編集したときに、 49 | 編集した長さだけ位置を調整します。 50 | `point`と同じ位置に挿入すると 51 | `:right-inserting`では元の位置のままで、`:left-inserting`では移動します。 52 | `:left-inserting`または`:right-inserting`の場合は、使用後に`delete-point`で明示的に削除するか、 53 | `with-point`を使う必要があります。 54 | "))) 55 | 56 | (setf (documentation 'point-buffer 'function) 57 | @lang(:jp "`point`が指す`buffer`を返します。")) 58 | 59 | (setf (documentation 'point-kind 'function) 60 | @lang(:jp "`point`の種類(`:temporary`、`:left-inserting`または`:right-inserting`)を返します。")) 61 | 62 | (defun current-point () 63 | @lang(:jp "現在の`point`を返します。") 64 | (buffer-point (current-buffer))) 65 | 66 | (defmethod print-object ((object point) stream) 67 | (print-unreadable-object (object stream :identity t) 68 | (format stream "POINT ~A ~S" 69 | (point-charpos object) 70 | (line-str (point-line object))))) 71 | 72 | (defun pointp (x) 73 | @lang(:jp "`x`が`point`ならT、それ以外ならNILを返します。") 74 | (typep x 'point)) 75 | 76 | (defun make-point (buffer linum line charpos &key (kind :right-inserting)) 77 | (check-type kind (member :temporary :left-inserting :right-inserting)) 78 | (let ((point (make-instance 'point 79 | :buffer buffer 80 | :linum linum 81 | :line line 82 | :charpos charpos 83 | :kind kind))) 84 | (unless (eq :temporary kind) 85 | (push point (line-points line)) 86 | (push point (buffer-points buffer))) 87 | point)) 88 | 89 | (defun copy-point (point &optional kind) 90 | @lang(:jp "`point`のコピーを作って返します。 91 | `kind`は`:temporary`、`:left-inserting`または `right-inserting`です。 92 | 省略された場合は`point`と同じ値です。") 93 | (make-point (point-buffer point) 94 | (point-linum point) 95 | (point-line point) 96 | (point-charpos point) 97 | :kind (or kind (point-kind point)))) 98 | 99 | (defun delete-point (point) 100 | @lang(:jp "`point`を削除します。 101 | `point-kind`が:temporaryの場合はこの関数を使う必要はありません。") 102 | (unless (point-temporary-p point) 103 | (setf (line-points (point-line point)) 104 | (delete point (line-points (point-line point)))) 105 | (let ((buffer (point-buffer point))) 106 | (setf (buffer-points buffer) 107 | (delete point (buffer-points buffer)))) 108 | (values))) 109 | 110 | (defun point-change-line (point new-linum new-line) 111 | (unless (point-temporary-p point) 112 | (let ((old-line (point-line point))) 113 | (if (line-alive-p old-line) 114 | (do ((scan (line-points old-line) (cdr scan)) 115 | (prev nil scan)) 116 | ((eq (car scan) point) 117 | (if prev 118 | (setf (cdr prev) (cdr scan)) 119 | (setf (line-points old-line) (cdr scan))) 120 | (setf (cdr scan) (line-points new-line) 121 | (line-points new-line) scan))) 122 | (push point (line-points new-line))))) 123 | (setf (point-linum point) new-linum) 124 | (setf (point-line point) new-line)) 125 | 126 | (defun point-temporary-p (point) 127 | (eq (point-kind point) :temporary)) 128 | 129 | (defun point= (point1 point2) 130 | @lang(:jp "`point1`と`point2`が同じ位置にあるならT、それ以外はNILを返します。") 131 | (assert (eq (point-buffer point1) 132 | (point-buffer point2))) 133 | (and (= (point-linum point1) 134 | (point-linum point2)) 135 | (= (point-charpos point1) 136 | (point-charpos point2)))) 137 | 138 | (defun point/= (point1 point2) 139 | @lang(:jp "`point1`と`point2`が同じ位置ではないならT、それ以外はNILを返します。") 140 | (assert (eq (point-buffer point1) 141 | (point-buffer point2))) 142 | (not (point= point1 point2))) 143 | 144 | (defun point< (point1 point2) 145 | @lang(:jp "`point1`が`point2`よりも前にあるならT、それ以外はNILを返します。") 146 | (assert (eq (point-buffer point1) 147 | (point-buffer point2))) 148 | (or (< (point-linum point1) (point-linum point2)) 149 | (and (= (point-linum point1) (point-linum point2)) 150 | (< (point-charpos point1) (point-charpos point2))))) 151 | 152 | (defun point<= (point1 point2) 153 | @lang(:jp "`point1`が`point2`と同じ位置、または前にあるならT、それ以外はNILを返します。") 154 | (assert (eq (point-buffer point1) 155 | (point-buffer point2))) 156 | (or (point< point1 point2) 157 | (point= point1 point2))) 158 | 159 | (defun point> (point1 point2) 160 | @lang(:jp "`point1`が`point2`よりも後にあるならT、それ以外はNILを返します。") 161 | (assert (eq (point-buffer point1) 162 | (point-buffer point2))) 163 | (point< point2 point1)) 164 | 165 | (defun point>= (point1 point2) 166 | @lang(:jp "`point1`が`point2`と同じ位置、または後にあるならT、それ以外はNILを返します。") 167 | (assert (eq (point-buffer point1) 168 | (point-buffer point2))) 169 | (point<= point2 point1)) 170 | -------------------------------------------------------------------------------- /lem-base/file.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-lsp.lem-base) 2 | 3 | (export '(*find-file-hook* 4 | *before-save-hook* 5 | *after-save-hook* 6 | *external-format-function* 7 | *find-directory-function* 8 | expand-file-name 9 | insert-file-contents 10 | find-file-buffer 11 | write-to-file 12 | update-changed-disk-date 13 | changed-disk-p)) 14 | 15 | (defvar *find-file-hook* '()) 16 | (defvar *before-save-hook* '()) 17 | (defvar *after-save-hook* '()) 18 | 19 | (defvar *external-format-function* nil) 20 | (defvar *find-directory-function* nil) 21 | 22 | (defun parse-pathname (pathname) 23 | (let ((path)) 24 | (loop 25 | (let ((pos (position #\/ pathname))) 26 | (when (null pos) 27 | (push pathname path) 28 | (return)) 29 | (let ((str (subseq pathname 0 pos))) 30 | (setq pathname (subseq pathname (1+ pos))) 31 | (cond ((string= str ".")) 32 | ((string= str "..") 33 | (pop path)) 34 | ((string= str "~") 35 | (setq path 36 | (nreverse 37 | (parse-pathname 38 | (string-right-trim 39 | '(#\/) 40 | (namestring 41 | (user-homedir-pathname))))))) 42 | ((string= str "") 43 | (setq path nil)) 44 | (t 45 | (push str path)))))) 46 | (nreverse path))) 47 | 48 | (defun expand-file-name (pathname &optional (directory (uiop:getcwd))) 49 | (format nil "/~{~A~^/~}" 50 | (parse-pathname 51 | (if (and (plusp (length pathname)) 52 | (char/= #\/ (aref pathname 0))) 53 | (namestring (merge-pathnames pathname directory)) 54 | pathname)))) 55 | 56 | (defun insert-file-contents (point filename) 57 | (let ((external-format :utf-8) 58 | (end-of-line :lf)) 59 | (when *external-format-function* 60 | (multiple-value-setq (external-format end-of-line) 61 | (funcall *external-format-function* filename))) 62 | (with-point ((point point :left-inserting)) 63 | (with-open-file (in filename :external-format external-format) 64 | (loop 65 | (multiple-value-bind (str eof-p) 66 | (read-line in nil) 67 | (cond 68 | (eof-p 69 | (when str 70 | (insert-string point str)) 71 | (return)) 72 | (t 73 | (let ((end nil)) 74 | #+sbcl 75 | (when (and (eq end-of-line :crlf) 76 | (< 0 (length str))) 77 | (setf end (1- (length str)))) 78 | (insert-string point 79 | (if end 80 | (subseq str 0 end) 81 | str)) 82 | (insert-character point #\newline)))))))))) 83 | 84 | (defun find-file-buffer (filename) 85 | (when (pathnamep filename) 86 | (setf filename (namestring filename))) 87 | (setf filename (expand-file-name filename)) 88 | (cond ((uiop:directory-pathname-p filename) 89 | (if *find-directory-function* 90 | (funcall *find-directory-function* filename) 91 | (editor-error "~A is a directory" filename))) 92 | ((find filename (buffer-list) :key #'buffer-filename :test #'equal)) 93 | (t 94 | (let* ((name (file-namestring filename)) 95 | (buffer (make-buffer (if (get-buffer name) 96 | (uniq-buffer-name name) 97 | name) 98 | :filename filename 99 | :enable-undo-p nil))) 100 | (when (probe-file filename) 101 | (let ((*inhibit-modification-hooks* t)) 102 | (insert-file-contents (buffer-start-point buffer) 103 | filename)) 104 | (buffer-unmark buffer)) 105 | (buffer-start (buffer-point buffer)) 106 | (buffer-enable-undo buffer) 107 | (update-changed-disk-date buffer) 108 | (run-hooks *find-file-hook* buffer) 109 | (values buffer t))))) 110 | 111 | (defun write-to-file-1 (buffer filename) 112 | (flet ((f (out end-of-line) 113 | (with-point ((point (buffer-start-point buffer))) 114 | (loop :for eof-p := (end-buffer-p point) 115 | :for str := (line-string point) 116 | :do 117 | (princ str out) 118 | (unless eof-p 119 | #+sbcl 120 | (ecase end-of-line 121 | ((:crlf) 122 | (princ #\return out) 123 | (princ #\newline out)) 124 | ((:lf) 125 | (princ #\newline out)) 126 | ((:cr) 127 | (princ #\return out))) 128 | #-sbcl 129 | (princ #\newline out) 130 | ) 131 | (unless (line-offset point 1) 132 | (return)))))) 133 | (cond 134 | ((buffer-external-format buffer) 135 | (with-open-file (out filename 136 | :direction :output 137 | :if-exists :supersede 138 | :if-does-not-exist :create 139 | :external-format (car (buffer-external-format 140 | buffer))) 141 | (f out 142 | (cdr (buffer-external-format 143 | buffer))))) 144 | (t 145 | (with-open-file (out filename 146 | :direction :output 147 | :if-exists :supersede 148 | :if-does-not-exist :create) 149 | (f out :lf)))))) 150 | 151 | (defun write-to-file (buffer filename) 152 | (run-hooks *before-save-hook* buffer) 153 | (write-to-file-1 buffer filename) 154 | (buffer-unmark buffer) 155 | (update-changed-disk-date buffer) 156 | (run-hooks *after-save-hook* buffer)) 157 | 158 | (defun file-write-date* (buffer) 159 | (if (probe-file (buffer-filename buffer)) 160 | (file-write-date (buffer-filename buffer)))) 161 | 162 | (defun update-changed-disk-date (buffer) 163 | (setf (buffer-last-write-date buffer) 164 | (file-write-date* buffer))) 165 | 166 | (defun changed-disk-p (buffer) 167 | (and (buffer-filename buffer) 168 | (uiop:file-exists-p (buffer-filename buffer)) 169 | (not (eql (buffer-last-write-date buffer) 170 | (file-write-date* buffer))))) 171 | -------------------------------------------------------------------------------- /lem-lisp-syntax/syntax-table.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-lsp.lem-lisp-syntax.syntax-table 2 | (:use :cl :cl-lsp.lem-base) 3 | (:export :*get-features-function* 4 | :*syntax-table*)) 5 | (in-package :cl-lsp.lem-lisp-syntax.syntax-table) 6 | 7 | (defvar *get-features-function* nil) 8 | 9 | (flet ((f (c1 c2 step-fn) 10 | (when c1 11 | (when (and (member c1 '(#\#)) 12 | (or (alphanumericp c2) 13 | (member c2 '(#\+ #\-)))) 14 | (funcall step-fn))))) 15 | 16 | (defun skip-expr-prefix-forward (point) 17 | (f (character-at point 0) 18 | (character-at point 1) 19 | (lambda () 20 | (character-offset point 2)))) 21 | 22 | (defun skip-expr-prefix-backward (point) 23 | (f (character-at point -2) 24 | (character-at point -1) 25 | (lambda () 26 | (character-offset point -2))))) 27 | 28 | (defun featurep (form) 29 | (cond ((atom form) 30 | (find (find-symbol (princ-to-string form) 31 | :keyword) 32 | (if *get-features-function* 33 | (funcall *get-features-function*) 34 | *features*))) 35 | ((string-equal 'and (car form)) 36 | (every #'featurep (cdr form))) 37 | ((string-equal 'or (car form)) 38 | (some #'featurep (cdr form))) 39 | (t))) 40 | 41 | (defparameter +symbol-package-prefix+ 42 | '(:sequence 43 | (:greedy-repetition 1 nil (:inverted-char-class #\( #\) #\space #\tab)) #\:)) 44 | 45 | (defun word-length-sort (&rest words) 46 | (sort (copy-list words) #'> :key #'length)) 47 | 48 | (defvar *syntax-table* 49 | (let ((table 50 | (make-syntax-table 51 | :space-chars '(#\space #\tab #\newline) 52 | :symbol-chars '(#\+ #\- #\< #\> #\/ #\* #\& #\= #\. #\? #\_ #\! #\$ #\% #\: #\@ #\[ #\] 53 | #\^ #\{ #\} #\~ #\# #\|) 54 | :paren-alist '((#\( . #\)) 55 | (#\[ . #\]) 56 | (#\{ . #\})) 57 | :string-quote-chars '(#\") 58 | :escape-chars '(#\\) 59 | :fence-chars '(#\|) 60 | :expr-prefix-chars '(#\' #\, #\@ #\# #\`) 61 | :expr-prefix-forward-function 'skip-expr-prefix-forward 62 | :expr-prefix-backward-function 'skip-expr-prefix-backward 63 | :line-comment-string ";" 64 | :block-comment-pairs '(("#|" . "|#"))))) 65 | (syntax-add-match table 66 | (make-syntax-test ":[^()\" \\t]+" 67 | :word-p t) 68 | :attribute 'syntax-constant-attribute) 69 | (syntax-add-match table 70 | (make-syntax-test "\\(") 71 | :matched-symbol :start-form 72 | :symbol-lifetime 1) 73 | (syntax-add-match table 74 | (make-syntax-test "[^() \\t]+") 75 | :test-symbol :define-start 76 | :attribute 'syntax-function-name-attribute) 77 | (syntax-add-match table 78 | (make-syntax-test "[^() \\t]+") 79 | :test-symbol :defpackage-start 80 | :attribute 'syntax-type-attribute) 81 | (syntax-add-match table 82 | (make-syntax-test "[^() \\t]+") 83 | :test-symbol :defvar-start 84 | :attribute 'syntax-variable-attribute) 85 | (syntax-add-match table 86 | (make-syntax-test 87 | `(:sequence 88 | (:greedy-repetition 0 1 ,+symbol-package-prefix+) 89 | (:alternation 90 | ,@(word-length-sort 91 | "defun" "defclass" "defgeneric" "defsetf" "defmacro" "defmethod") 92 | (:sequence "define-" (:greedy-repetition 0 nil 93 | (:inverted-char-class #\space #\tab #\( #\)))))) 94 | :word-p t) 95 | :test-symbol :start-form 96 | :attribute 'syntax-keyword-attribute 97 | :matched-symbol :define-start 98 | :symbol-lifetime 1) 99 | (syntax-add-match table 100 | (make-syntax-test 101 | `(:sequence 102 | (:greedy-repetition 0 1 ,+symbol-package-prefix+) 103 | (:alternation 104 | ,@(word-length-sort 105 | "deftype" "defpackage" "defstruct"))) 106 | :word-p t) 107 | :test-symbol :start-form 108 | :attribute 'syntax-keyword-attribute 109 | :matched-symbol :defpackage-start 110 | :symbol-lifetime 1) 111 | (syntax-add-match table 112 | (make-syntax-test 113 | `(:sequence 114 | (:greedy-repetition 0 1 ,+symbol-package-prefix+) 115 | (:alternation 116 | ,@(word-length-sort "defvar" "defparameter" "defconstant"))) 117 | :word-p t) 118 | :test-symbol :start-form 119 | :attribute 'syntax-keyword-attribute 120 | :matched-symbol :defvar-start 121 | :symbol-lifetime 1) 122 | (syntax-add-match table 123 | (make-syntax-test 124 | `(:sequence 125 | (:greedy-repetition 0 1 ,+symbol-package-prefix+) 126 | (:alternation 127 | ,@(word-length-sort 128 | "block" "case" "ccase" "ecase" "typecase" "etypecase" "ctypecase" "catch" 129 | "cond" "destructuring-bind" "do" "do*" "dolist" "dotimes" 130 | "eval-when" "flet" "labels" "macrolet" "generic-flet" "generic-labels" 131 | "handler-case" "restart-case" "if" "lambda" "let" "let*" "handler-bind" 132 | "restart-bind" "locally" "multiple-value-bind" "multiple-value-call" 133 | "multiple-value-prog1" "prog" "prog*" "prog1" "prog2" "progn" "progv" "return" 134 | "return-from" "symbol-macrolet" "tagbody" "throw" "unless" "unwind-protect" 135 | "when" "with-accessors" "with-condition-restarts" "with-open-file" 136 | "with-output-to-string" "with-slots" "with-standard-io-syntax" "loop" 137 | "declare" "declaim" "proclaim"))) 138 | :word-p t) 139 | :test-symbol :start-form 140 | :attribute 'syntax-keyword-attribute) 141 | (syntax-add-match table 142 | (make-syntax-test "&[^() \\t]+" 143 | :word-p t) 144 | :attribute 'syntax-constant-attribute) 145 | (syntax-add-match 146 | table 147 | (make-syntax-test "#[+-]") 148 | :move-action (lambda (cur-point) 149 | (ignore-errors 150 | (let ((positivep (eql #\+ (character-at cur-point 1)))) 151 | (character-offset cur-point 2) 152 | (with-point ((prev cur-point)) 153 | (when (form-offset cur-point 1) 154 | (cond 155 | ((if (featurep (read-from-string 156 | (points-to-string 157 | prev cur-point))) 158 | positivep 159 | (not positivep)) 160 | nil) 161 | (t 162 | (form-offset cur-point 1)))))))) 163 | :attribute 'syntax-comment-attribute) 164 | table)) 165 | -------------------------------------------------------------------------------- /eval.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-lsp/eval 2 | (:use :cl 3 | :cl-lsp/logger 4 | :cl-lsp/server 5 | :cl-lsp/protocol 6 | :cl-lsp/protocol-util 7 | :cl-lsp/slime 8 | :cl-lsp/swank 9 | :cl-lsp/gray-streams) 10 | (:import-from :cl-lsp.lem-base 11 | :with-point 12 | :points-to-string)) 13 | (in-package :cl-lsp/eval) 14 | 15 | (defvar *eval-thread* nil) 16 | 17 | (let ((wait (bt:make-condition-variable)) 18 | (lock (bt:make-lock)) 19 | (queue (list))) 20 | 21 | (defun receive () 22 | (bt:with-lock-held (lock) 23 | (bt:condition-wait wait lock) 24 | (pop queue))) 25 | 26 | (defun send (x) 27 | (bt:with-lock-held (lock) 28 | (setf queue (nconc queue (list x))) 29 | (bt:condition-notify wait)))) 30 | 31 | (defun ensure-package (package) 32 | (or (find-package package) 33 | (find-package "CL-USER"))) 34 | 35 | (defun start-eval-thread () 36 | (unless *eval-thread* 37 | (setf *eval-thread* 38 | (bt:make-thread 39 | (lambda () 40 | (with-error-handle 41 | (loop :for event := (receive) :do 42 | (funcall event)))))))) 43 | 44 | (pushnew 'start-eval-thread *initialized-hooks*) 45 | 46 | (defun send-eval (function) 47 | (jsonrpc:notify-async *server* "lisp/evalBegin" nil) 48 | (send (lambda () 49 | (funcall function) 50 | (bt:with-lock-held (*method-lock*) 51 | (jsonrpc:notify-async *server* "lisp/evalEnd" nil))))) 52 | 53 | (defun lsp-output-fn (string) 54 | (bt:with-lock-held (*method-lock*) 55 | (notify-log-message |MessageType.Log| string))) 56 | 57 | (defun call-with-eval-stream (function) 58 | (let ((out (make-instance 'lsp-output-stream :output-fn #'lsp-output-fn))) 59 | (with-input-from-string (in "") 60 | (with-open-stream (eval-stream (make-two-way-stream in out)) 61 | (let ((*standard-output* eval-stream) 62 | (*error-output* eval-stream) 63 | (*standard-input* eval-stream) 64 | (*terminal-io* eval-stream) 65 | (*query-io* eval-stream) 66 | (*debug-io* eval-stream) 67 | (*trace-output* eval-stream)) 68 | (funcall function eval-stream)))))) 69 | 70 | (defmacro with-eval-stream ((stream-var) &body body) 71 | `(call-with-eval-stream (lambda (,stream-var) ,@body))) 72 | 73 | (defun call-with-muffle-streams (function) 74 | (let ((stream (make-broadcast-stream))) 75 | (let ((*standard-output* stream) 76 | (*error-output* stream) 77 | (*standard-input* stream) 78 | (*terminal-io* stream) 79 | (*query-io* stream) 80 | (*debug-io* stream) 81 | (*trace-output* stream)) 82 | (funcall function)))) 83 | 84 | (defmacro with-muffle-streams (() &body body) 85 | `(call-with-muffle-streams (lambda () ,@body))) 86 | 87 | 88 | (defun compilation-notes-to-diagnostics (notes) 89 | (let ((diagnostics '())) 90 | (compilation-notes 91 | notes 92 | (lambda (start end severity message) 93 | (push (make-instance '|Diagnostic| 94 | :|range| (make-lsp-range start end) 95 | :|severity| (case severity 96 | ((:error :read-error) 97 | |DiagnosticSeverity.Error|) 98 | ((:warning :style-warning) 99 | |DiagnosticSeverity.Warning|) 100 | ((:note :redefinition) 101 | |DiagnosticSeverity.Information|)) 102 | ;; :|code| 103 | ;; :|source| 104 | :|message| message) 105 | diagnostics))) 106 | (list-to-object[] diagnostics))) 107 | 108 | (defun compilation-message (notes secs successp) 109 | (with-output-to-string (out) 110 | (if successp 111 | (princ "Compilation finished" out) 112 | (princ "Compilation failed" out)) 113 | (princ (if (null notes) 114 | ". (No warnings)" 115 | ". ") 116 | out) 117 | (when secs 118 | (format nil "[~,2f secs]" secs)))) 119 | 120 | (defun compile-and-load-file (uri) 121 | (let ((filename (uri-to-filename uri)) 122 | result) 123 | (handler-case (with-muffle-streams () 124 | (setf result (swank-compile-file filename t))) 125 | (error (c) 126 | (bt:with-lock-held (*method-lock*) 127 | (notify-show-message |MessageType.Error| 128 | (princ-to-string c))) 129 | (setf result nil))) 130 | (when result 131 | (destructuring-bind (notes successp duration loadp fastfile) 132 | (rest result) 133 | (bt:with-lock-held (*method-lock*) 134 | (notify-show-message |MessageType.Info| 135 | (compilation-message 136 | notes duration successp)) 137 | (jsonrpc:notify-async 138 | *server* 139 | "textDocument/publishDiagnostics" 140 | (convert-to-hash-table 141 | (make-instance '|PublishDiagnosticsParams| 142 | :|uri| uri 143 | :|diagnostics| (compilation-notes-to-diagnostics notes))))) 144 | (when (and loadp fastfile successp) 145 | (handler-case 146 | (with-eval-stream (eval-stream) 147 | (load fastfile) 148 | (finish-output eval-stream)) 149 | (error (condition) 150 | (bt:with-lock-held (*method-lock*) 151 | (notify-show-message |MessageType.Error| 152 | (princ-to-string condition)))))))))) 153 | 154 | (define-method "lisp/compileAndLoadFile" (params |TextDocumentIdentifier|) 155 | (let* ((uri (slot-value params '|uri|))) 156 | (send-eval (lambda () (compile-and-load-file uri)))) 157 | nil) 158 | 159 | (defun eval-string (string package) 160 | (let ((*package* (ensure-package package)) 161 | results) 162 | (with-eval-stream (eval-stream) 163 | (handler-bind 164 | ((error (lambda (err) 165 | (finish-output eval-stream) 166 | (bt:with-lock-held (*method-lock*) 167 | (notify-log-message |MessageType.Error| 168 | (with-output-to-string (out) 169 | (format out "~%~A~%~%" err) 170 | (uiop:print-backtrace :stream out))) 171 | (notify-show-message |MessageType.Error| 172 | (princ-to-string err))) 173 | (return-from eval-string)))) 174 | (setf results 175 | (multiple-value-list 176 | (eval (read-from-string string))))) 177 | (finish-output eval-stream) 178 | (bt:with-lock-held (*method-lock*) 179 | (notify-show-message |MessageType.Info| (format nil "~{~A~^, ~}" results)))))) 180 | 181 | (defun send-eval-string (string package) 182 | (send-eval (lambda () (eval-string string package)))) 183 | 184 | (define-method "lisp/eval" (params |TextDocumentPositionParams|) 185 | (with-text-document-position (point) params 186 | (let ((string (form-string point))) 187 | (when string 188 | (let ((package (search-buffer-package point))) 189 | (send-eval-string string package))) 190 | nil))) 191 | 192 | (define-method "lisp/rangeEval" (params) 193 | (let* ((uri (gethash "uri" (gethash "textDocument" params))) 194 | (range (convert-from-hash-table '|Range| (gethash "range" params)))) 195 | (with-slots (|start| |end|) range 196 | (with-document-position (start uri |start|) 197 | (with-point ((end start)) 198 | (move-to-lsp-position end |end|) 199 | (send-eval-string (points-to-string start end) 200 | (search-buffer-package start))))))) 201 | 202 | (define-method "lisp/interrupt" (params nil t) 203 | (when *eval-thread* 204 | (bt:interrupt-thread *eval-thread* 205 | (lambda () 206 | (error "interrupt")))) 207 | nil) 208 | -------------------------------------------------------------------------------- /lem-base/line.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-lsp.lem-base) 2 | 3 | (defconstant +line-increment+ 256) 4 | 5 | (defstruct (line (:constructor %make-line)) 6 | prev 7 | next 8 | str 9 | plist 10 | %symbol-lifetimes 11 | %syntax-context 12 | points) 13 | 14 | (defmethod print-object ((object line) stream) 15 | (print-unreadable-object (object stream :identity t) 16 | (format stream "LINE: string: ~S, plist: ~S" 17 | (line-str object) 18 | (line-plist object)))) 19 | 20 | (defun make-line (prev next str) 21 | (let ((line (%make-line :next next 22 | :prev prev 23 | :str str))) 24 | (when next 25 | (setf (line-prev next) line)) 26 | (when prev 27 | (setf (line-next prev) line)) 28 | line)) 29 | 30 | (defun line-alive-p (line) 31 | (not (null (line-str line)))) 32 | 33 | (defun line-char (line i) 34 | (if (= i (line-length line)) 35 | #\newline 36 | (char (line-str line) i))) 37 | 38 | (defun line-length (line) 39 | (length (line-str line))) 40 | 41 | (defun remove-elements (elements start end) 42 | (iter:iter (iter:for (start1 end1 value1) iter:in elements) 43 | (cond 44 | ((<= start start1 end1 end) 45 | nil) 46 | ((<= start start1 end end1) 47 | (iter:collect (list end end1 value1))) 48 | ((<= start1 start end1 end) 49 | (iter:collect (list start1 start value1))) 50 | ((<= start1 start end end1) 51 | (iter:collect (list start1 start value1)) 52 | (iter:collect (list end end1 value1))) 53 | (t 54 | (iter:collect (list start1 end1 value1)))))) 55 | 56 | (defun normalization-elements (elements) 57 | (flet ((start (elt) (first elt)) 58 | (end (elt) (second elt)) 59 | (value (elt) (third elt))) 60 | (setf elements (sort elements #'< :key #'first)) 61 | (iter:iter (iter:until (null elements)) 62 | (cond 63 | ((and (eql (end (first elements)) 64 | (start (second elements))) 65 | (equal (value (first elements)) 66 | (value (second elements)))) 67 | (iter:collect (list (start (first elements)) 68 | (end (second elements)) 69 | (value (first elements)))) 70 | (setf elements (cddr elements))) 71 | (t 72 | (iter:collect (first elements)) 73 | (setf elements (cdr elements))))))) 74 | 75 | (defun subseq-elements (elements start end) 76 | (iter:iter (iter:for (start1 end1 value1) iter:in elements) 77 | (cond 78 | ((<= start start1 end1 end) 79 | (iter:collect (list (- start1 start) (- end1 start) value1))) 80 | ((<= start start1 end end1) 81 | (iter:collect (list (- start1 start) (- end start) value1))) 82 | ((<= start1 start end1 end) 83 | (iter:collect (list (- start start) (- end1 start) value1))) 84 | ((<= start1 start end end1) 85 | (iter:collect (list (- start start) (- end start) value1)))))) 86 | 87 | (defun offset-elements (elements n) 88 | (iter:iter (iter:for (start1 end1 value1) iter:in elements) 89 | (iter:collect (list (+ n start1) (+ n end1) value1)))) 90 | 91 | (defun put-elements (elements start end value &optional contp) 92 | (normalization-elements 93 | (cons (list start end value contp) 94 | (remove-elements elements start end)))) 95 | 96 | (defun merge-plist (plist1 plist2) 97 | (let ((new-plist '())) 98 | (flet ((f (plist) 99 | (loop :for (k v) :on plist :by #'cddr 100 | :do (setf (getf new-plist k) 101 | (nconc (getf new-plist k) v))))) 102 | (f plist1) 103 | (f plist2)) 104 | new-plist)) 105 | 106 | (defun line-merge (curr-line next-line pos) 107 | (setf (line-plist curr-line) 108 | (merge-plist 109 | (line-plist curr-line) 110 | (loop :for (key elements) :on (line-plist next-line) :by #'cddr 111 | :append (let ((new-elements 112 | (loop :for (start end value) :in elements 113 | :collect (list (+ start pos) 114 | (+ end pos) 115 | value)))) 116 | (when new-elements 117 | (list key new-elements))))))) 118 | 119 | (defun line-normalization-plist (line) 120 | (loop :for (key elements) :on (line-plist line) :by #'cddr 121 | :collect (cons key (normalization-elements elements)))) 122 | 123 | (defun line-remove-property (line start end key) 124 | (setf (getf (line-plist line) key) 125 | (normalization-elements (remove-elements (getf (line-plist line) key) start end)))) 126 | 127 | (defun line-add-property (line start end key value contp) 128 | (assert (<= 0 start (line-length line))) 129 | (assert (<= 0 end (line-length line))) 130 | (assert (<= start end)) 131 | (setf (getf (line-plist line) key) 132 | (put-elements (getf (line-plist line) key) 133 | start end value contp))) 134 | 135 | (defun line-clear-property (line key) 136 | (setf (getf (line-plist line) key) nil)) 137 | 138 | (defun line-search-property (line key pos) 139 | (loop :for (start end value contp) :in (getf (line-plist line) key) 140 | :do (when (if contp 141 | (<= start pos end) 142 | (<= start pos (1- end))) 143 | (return value)))) 144 | 145 | (defun line-search-property-range (line key pos-start pos-end) 146 | (when (null pos-end) 147 | (setq pos-end most-positive-fixnum)) 148 | (loop :for (start end value contp) :in (getf (line-plist line) key) 149 | :do (when (or (<= pos-start start pos-end) 150 | (if contp 151 | (<= start pos-start end) 152 | (<= start pos-start (1- end)))) 153 | (return value)))) 154 | 155 | (defun line-property-insert-pos (line pos offset) 156 | (loop :for values :in (cdr (line-plist line)) :by #'cddr 157 | :do (loop :for v :in values 158 | :for (start end) := v 159 | :do (cond ((<= pos start) 160 | (incf (first v) offset) 161 | (incf (second v) offset)) 162 | ((< start pos end) 163 | (incf (second v) offset)) 164 | ((< pos end) 165 | (incf (second v) offset)))))) 166 | 167 | (defun line-property-insert-newline (line next-line pos) 168 | (let ((new-plist '())) 169 | (loop :for plist-rest :on (line-plist line) :by #'cddr 170 | :do (let ((new-values '()) 171 | (new-values-last nil)) 172 | (setf (cadr plist-rest) 173 | (iter:iter 174 | (iter:for elt iter:in (cadr plist-rest)) 175 | (iter:for (start end value) iter:next elt) 176 | (cond ((<= pos start) 177 | (let ((new-elt (list (list (- start pos) (- end pos) value)))) 178 | (cond 179 | (new-values-last 180 | (setf (cdr new-values-last) new-elt) 181 | (setf new-values-last (cdr new-values-last))) 182 | (t 183 | (setf new-values new-elt) 184 | (setf new-values-last new-elt))))) 185 | ((<= pos end) 186 | (iter:collect (list start pos value))) 187 | (t 188 | (iter:collect elt))))) 189 | (unless (null new-values) 190 | (setf (getf new-plist (car plist-rest)) new-values)))) 191 | (setf (line-plist next-line) new-plist))) 192 | 193 | (defun line-property-delete-pos (line pos n) 194 | (loop :for plist-rest :on (line-plist line) :by #'cddr 195 | :do (setf (cadr plist-rest) 196 | (loop :for elt :in (cadr plist-rest) 197 | :for (start end value) := elt 198 | :if (<= pos start end (+ pos n)) 199 | :do (progn) 200 | :else :if (<= pos (+ pos n) start) 201 | :collect (list (- start n) (- end n) value) 202 | :else :if (< pos start (+ pos n)) 203 | :collect (list pos (- end n) value) 204 | :else :if (<= start pos (+ pos n) end) 205 | :collect (list start (- end n) value) 206 | :else :if (<= start pos end (+ pos n)) 207 | :collect (list start pos value) 208 | :else 209 | :collect elt)))) 210 | 211 | (defun line-property-delete-line (line pos) 212 | (loop :for plist-rest :on (line-plist line) :by #'cddr 213 | :do (setf (cadr plist-rest) 214 | (loop :for elt :in (cadr plist-rest) 215 | :for (start end value) := elt 216 | :if (<= pos start) 217 | :do (progn) 218 | :else :if (<= pos end) 219 | :collect (list start pos value) 220 | :else 221 | :collect elt 222 | )))) 223 | 224 | (defun line-string/attributes (line) 225 | (cons (line-str line) 226 | (getf (line-plist line) :attribute))) 227 | 228 | (defun line-free (line) 229 | (when (line-prev line) 230 | (setf (line-next (line-prev line)) 231 | (line-next line))) 232 | (when (line-next line) 233 | (setf (line-prev (line-next line)) 234 | (line-prev line))) 235 | (setf (line-prev line) nil 236 | (line-next line) nil 237 | (line-str line) nil 238 | (line-points line) nil)) 239 | -------------------------------------------------------------------------------- /lem-base/search.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-lsp.lem-base) 2 | 3 | (export '(*case-fold-search* 4 | search-forward 5 | search-backward 6 | search-forward-regexp 7 | search-backward-regexp 8 | search-forward-symbol 9 | search-backward-symbol 10 | looking-at 11 | match-string-at)) 12 | 13 | (defvar *case-fold-search* nil) 14 | 15 | (defun search-step (point first-search search step move-matched endp) 16 | (with-point ((start-point point)) 17 | (let ((result 18 | (let ((res (funcall first-search point))) 19 | (cond (res 20 | (funcall move-matched point res) 21 | (not (funcall endp point))) 22 | (t 23 | (loop :until (funcall endp point) :do 24 | (unless (funcall step point) 25 | (return nil)) 26 | (let ((res (funcall search point))) 27 | (when res 28 | (funcall move-matched point res) 29 | (return t))))))))) 30 | (unless result 31 | (move-point point start-point)) 32 | result))) 33 | 34 | (defun search-forward-endp-function (limit-point) 35 | (if limit-point 36 | (lambda (point) 37 | (or (point<= limit-point point) 38 | (end-buffer-p point))) 39 | #'end-buffer-p)) 40 | 41 | (defun search-backward-endp-function (limit-point) 42 | (if limit-point 43 | (lambda (point) 44 | (point< point limit-point)) 45 | #'start-buffer-p)) 46 | 47 | (defmacro search* (&rest args) 48 | `(search ,@args 49 | :test (if *case-fold-search* 50 | #'char= 51 | #'char-equal))) 52 | 53 | (defun search-forward (point string &optional limit-point) 54 | (let ((nlines (count #\newline string))) 55 | (flet ((take-string (point) 56 | (with-point ((start-point point) 57 | (end-point point)) 58 | (points-to-string (line-start start-point) 59 | (line-end (or (line-offset end-point nlines) 60 | (buffer-end end-point))))))) 61 | (search-step point 62 | (lambda (point) 63 | (search* string 64 | (take-string point) 65 | :start2 (point-charpos point))) 66 | (lambda (point) 67 | (search* string (take-string point))) 68 | (lambda (point) 69 | (line-offset point 1)) 70 | (lambda (point charpos) 71 | (character-offset (line-start point) 72 | (+ charpos (length string)))) 73 | (search-forward-endp-function limit-point))))) 74 | 75 | (defun search-backward (point string &optional limit-point) 76 | (let ((nlines (count #\newline string))) 77 | (flet ((search-from-end (point end-charpos) 78 | (with-point ((point point)) 79 | (when (line-offset point (- nlines)) 80 | (search* string 81 | (points-to-string 82 | (line-start (copy-point point :temporary)) 83 | (with-point ((point point)) 84 | (unless (line-offset point nlines) 85 | (buffer-end point)) 86 | (if end-charpos 87 | (character-offset point end-charpos) 88 | (line-end point)))) 89 | :from-end t))))) 90 | (let ((end-charpos (point-charpos point))) 91 | (search-step point 92 | (lambda (point) 93 | (search-from-end point end-charpos)) 94 | (lambda (point) 95 | (search-from-end point nil)) 96 | (lambda (point) 97 | (line-offset point -1)) 98 | (lambda (point charpos) 99 | (unless (zerop nlines) 100 | (line-offset point (- nlines))) 101 | (character-offset (line-start point) charpos)) 102 | (search-backward-endp-function limit-point)))))) 103 | 104 | (defun search-forward-regexp (point regex &optional limit-point) 105 | (let ((scanner (ignore-errors (ppcre:create-scanner regex)))) 106 | (when scanner 107 | (search-step point 108 | (lambda (point) 109 | (multiple-value-bind (start end) 110 | (ppcre:scan scanner 111 | (line-string point) 112 | :start (point-charpos point)) 113 | (when (and start (<= (point-charpos point) start)) 114 | end))) 115 | (lambda (point) 116 | (nth-value 1 117 | (ppcre:scan scanner 118 | (line-string point)))) 119 | (lambda (point) 120 | (line-offset point 1)) 121 | (lambda (point charpos) 122 | (character-offset (line-start point) charpos)) 123 | (search-forward-endp-function limit-point))))) 124 | 125 | (defun search-backward-regexp (point regex &optional limit-point) 126 | (let ((scanner (ignore-errors (ppcre:create-scanner regex)))) 127 | (when scanner 128 | (search-step point 129 | (lambda (point) 130 | (let (pos) 131 | (ppcre:do-scans (start end reg-starts reg-ends scanner 132 | (line-string point) nil 133 | :end (point-charpos point)) 134 | (setf pos start)) 135 | pos)) 136 | (lambda (point) 137 | (let (pos) 138 | (ppcre:do-scans (start end reg-starts reg-ends scanner 139 | (line-string point) nil 140 | :start (point-charpos point)) 141 | (setf pos start)) 142 | pos)) 143 | (lambda (point) 144 | (line-offset point -1)) 145 | (lambda (point charpos) 146 | (character-offset (line-start point) charpos)) 147 | (search-backward-endp-function limit-point))))) 148 | 149 | (defun search-symbol (string name &key (start 0) (end (length string)) from-end) 150 | (loop :while (< start end) 151 | :do (let ((pos (search name string :start2 start :end2 end :from-end from-end))) 152 | (when pos 153 | (let ((pos2 (+ pos (length name)))) 154 | (when (and (or (zerop pos) 155 | (not (syntax-symbol-char-p (aref string (1- pos))))) 156 | (or (>= pos2 (length string)) 157 | (not (syntax-symbol-char-p (aref string pos2))))) 158 | (return (cons pos pos2))))) 159 | (if from-end 160 | (setf end (1- (or pos end))) 161 | (setf start (1+ (or pos start))))))) 162 | 163 | (defun search-forward-symbol (point name &optional limit-point) 164 | (let ((charpos (point-charpos point))) 165 | (search-step point 166 | (lambda (point) 167 | (cdr (search-symbol (line-string point) name :start charpos))) 168 | (lambda (point) 169 | (cdr (search-symbol (line-string point) name))) 170 | (lambda (point) 171 | (line-offset point 1)) 172 | (lambda (point charpos) 173 | (line-offset point 0 charpos)) 174 | (search-forward-endp-function limit-point)))) 175 | 176 | (defun search-backward-symbol (point name &optional limit-point) 177 | (search-step point 178 | (lambda (point) 179 | (car (search-symbol (line-string point) 180 | name 181 | :end (point-charpos point) 182 | :from-end t))) 183 | (lambda (point) 184 | (car (search-symbol (line-string point) 185 | name 186 | :from-end t))) 187 | (lambda (point) 188 | (line-offset point -1)) 189 | (lambda (point charpos) 190 | (line-offset point 0 charpos)) 191 | (search-backward-endp-function limit-point))) 192 | 193 | (defun looking-at (point regex) 194 | (let ((start (point-charpos point)) 195 | (string (line-string point))) 196 | (multiple-value-bind (match-start match-end reg-starts reg-ends) 197 | (ppcre:scan regex string :start start) 198 | (when (eql match-start start) 199 | (values (subseq string match-start match-end) 200 | (map 'vector 201 | (lambda (reg-start reg-end) 202 | (when reg-start 203 | (subseq string reg-start reg-end))) 204 | reg-starts 205 | reg-ends)))))) 206 | 207 | (defun match-string-at (point string &optional across-line-p) 208 | (let ((overp 209 | (> (+ (point-charpos point) (length string)) 210 | (length (line-string point))))) 211 | (cond ((and across-line-p overp) 212 | (string= string 213 | (points-to-string point 214 | (character-offset (copy-point point :temporary) 215 | (length string))))) 216 | (overp 217 | nil) 218 | (t 219 | (string= (line-string point) string 220 | :start1 (point-charpos point) 221 | :end1 (+ (length string) 222 | (point-charpos point))))))) 223 | -------------------------------------------------------------------------------- /lem-lisp-syntax/indent.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-lsp.lem-lisp-syntax.indent 2 | (:use :cl :cl-lsp.lem-base) 3 | (:export :*get-method-function* 4 | :set-indentation 5 | :calc-indent)) 6 | (in-package :cl-lsp.lem-lisp-syntax.indent) 7 | 8 | (defparameter *body-indent* 2) 9 | (defparameter *max-depth* 4) 10 | 11 | (defvar *get-method-function* nil) 12 | (defvar *indent-table* (make-hash-table :test 'equal)) 13 | 14 | (defun get-indentation (name) 15 | (gethash name *indent-table*)) 16 | 17 | (defun set-indentation (name method) 18 | (setf (gethash name *indent-table*) method)) 19 | 20 | (mapc (lambda (elt) 21 | (let ((name (car elt)) 22 | (method (if (stringp (cdr elt)) 23 | (get-indentation (cdr elt)) 24 | (cadr elt)))) 25 | (set-indentation name method))) 26 | '(("block" 1) 27 | ("case" (4 &rest (&whole 2 &rest 1))) 28 | ("ccase" . "case") 29 | ("ecase" . "case") 30 | ("typecase" . "case") 31 | ("etypecase" . "case") 32 | ("ctypecase" . "case") 33 | ("catch" 1) 34 | ("cond" (&rest (&whole 2 &rest 1))) 35 | ("defvar" (4 2 2)) 36 | ("defclass" (6 4 (&whole 2 &rest 1) (&whole 2 &rest 1))) 37 | ("defconstant" . "defvar") 38 | ("defcustom" (4 2 2 2)) 39 | ("defparameter" . "defvar") 40 | ("defconst" . "defcustom") 41 | ("define-condition" . "defclass") 42 | ("define-modify-macro" (4 &lambda &body)) 43 | ("defsetf" (4 &lambda 4 &body)) 44 | ("defun" (4 &lambda &body)) 45 | ("defgeneric" (4 &lambda &body)) 46 | ("define-setf-method" . "defun") 47 | ("define-setf-expander" . "defun") 48 | ("defmacro" . "defun") 49 | ("defsubst" . "defun") 50 | ("deftype" . "defun") 51 | ("defmethodlisp-indent-defmethod") 52 | ("defpackage" (4 2)) 53 | ("defstruct" ((&whole 4 &rest (&whole 2 &rest 1)) 54 | &rest (&whole 2 &rest 1))) 55 | ("destructuring-bind" 56 | ((&whole 6 &rest 1) 4 &body)) 57 | ;("do" lisp-indent-do) 58 | ("do" 2) 59 | ("do*" . "do") 60 | ("dolist" ((&whole 4 2 1) &body)) 61 | ("dotimes" . "dolist") 62 | ("eval-when" 1) 63 | ("flet" ((&whole 4 &rest (&whole 1 &lambda &body)) &body)) 64 | ("labels" . "flet") 65 | ("macrolet" . "flet") 66 | ("generic-flet" . "flet") 67 | ("generic-labels" . "flet") 68 | ("handler-case" (4 &rest (&whole 2 &lambda &body))) 69 | ("restart-case" . "handler-case") 70 | ;; `else-body' style 71 | ("if" (nil nil &body)) 72 | ;; single-else style (then and else equally indented) 73 | ("if" (&rest nil)) 74 | ;("lambda" (&lambda &rest lisp-indent-function-lambda-hack)) 75 | ("lambda" (&lambda &body)) 76 | ("let" ((&whole 4 &rest (&whole 1 1 2)) &body)) 77 | ("let*" . "let") 78 | ("compiler-let" . "let") ;barf 79 | ("handler-bind" . "let") 80 | ("restart-bind" . "let") 81 | ("locally" 1) 82 | ;("loop" lisp-indent-loop) 83 | ("loop" (&rest &body)) 84 | (":method" (&lambda &body)) ; in `defgeneric' 85 | ("multiple-value-bind" ((&whole 6 &rest 1) 4 &body)) 86 | ("multiple-value-call" (4 &body)) 87 | ("multiple-value-prog1" 1) 88 | ("multiple-value-setq" (4 2)) 89 | ("multiple-value-setf" . "multiple-value-setq") 90 | ("pprint-logical-block" (4 2)) 91 | ("print-unreadable-object" ((&whole 4 1 &rest 1) &body)) 92 | ;; Combines the worst features of BLOCK, LET and TAGBODY 93 | ("prog" (&lambda &rest lisp-indent-tagbody)) 94 | ("prog*" . "prog") 95 | ("prog1" 1) 96 | ("prog2" 2) 97 | ("progn" 0) 98 | ("progv" (4 4 &body)) 99 | ("return" 0) 100 | ("return-from" (nil &body)) 101 | ("symbol-macrolet" . "let") 102 | ;("tagbody" lisp-indent-tagbody) 103 | ("tagbody" 0) 104 | ("throw" 1) 105 | ("unless" 1) 106 | ("unwind-protect" (5 &body)) 107 | ("when" 1) 108 | ("with-accessors" . "multiple-value-bind") 109 | ("with-condition-restarts" . "multiple-value-bind") 110 | ("with-compilation-unit" (&lambda &body)) 111 | ("with-output-to-string" (4 2)) 112 | ("with-slots" . "multiple-value-bind") 113 | ("with-standard-io-syntax" (2)))) 114 | 115 | (defun lisp-indent-loop (path indent-point sexp-column) 116 | (declare (ignore path indent-point sexp-column)) 117 | 'default-indent) 118 | 119 | (defun lisp-indent-do (path indent-point sexp-column) 120 | (declare (ignore path indent-point sexp-column)) 121 | 'default-indent) 122 | 123 | (defun lisp-indent-function-lambda-hack (path indent-point sexp-column) 124 | (declare (ignore path indent-point sexp-column)) 125 | 'default-indent) 126 | 127 | (defun lisp-indent-tagbody (path indent-point sexp-column) 128 | (declare (ignore path indent-point sexp-column)) 129 | 'default-indent) 130 | 131 | (defun compute-indent-lambda-list (path indent-point sexp-column) 132 | (declare (ignore path indent-point sexp-column)) 133 | 'default-indent) 134 | 135 | (defun compute-indent-integer-method (method path indent-point sexp-column) 136 | (declare (ignore indent-point)) 137 | (cond ((cdr path) 138 | 'default-indent) 139 | ((<= (car path) method) 140 | (+ sexp-column 4)) 141 | (t 142 | (+ sexp-column *body-indent*)))) 143 | 144 | (defun compute-indent-symbol-method (method path indent-point sexp-column) 145 | (funcall method path indent-point sexp-column)) 146 | 147 | (defun compute-indent-complex-method (method path indent-point sexp-column) 148 | (loop :named exit 149 | :for pathrest :on path 150 | :for n := (1- (car pathrest)) 151 | :do (let ((restp nil)) 152 | (loop 153 | (let ((method1 (car method))) 154 | (cond ((and restp (not (or (consp method1) (symbolp method1)))) 155 | (return-from exit 156 | 'default-indent)) 157 | ((eq method1 '&body) 158 | (return-from exit 159 | (if (null (cdr pathrest)) 160 | (+ sexp-column *body-indent*) 161 | 'default-indent))) 162 | ((eq method1 '&rest) 163 | (setf restp (> n 0)) 164 | (setf n 0) 165 | (pop method)) 166 | ((> n 0) 167 | (decf n) 168 | (pop method)) 169 | ((eq method1 'nil) 170 | (return-from exit 171 | 'default-indent)) 172 | ((eq method1 '&lambda) 173 | (return-from exit 174 | (cond ((null (cdr pathrest)) 175 | (+ sexp-column 4)) 176 | ((null (cddr pathrest)) 177 | (compute-indent-lambda-list path indent-point sexp-column)) 178 | (t 179 | 'default-indent)))) 180 | ((integerp method1) 181 | (return-from exit 182 | (if (null (cdr pathrest)) 183 | (+ sexp-column method1) 184 | 'default-indent))) 185 | ((symbolp method1) 186 | (return-from exit 187 | (compute-indent-symbol-method method1 path indent-point sexp-column))) 188 | ;; (&whole ...) 189 | ((not (null (cdr pathrest))) 190 | (setf method (cddr method1)) 191 | (return)) 192 | (t 193 | (return-from exit 194 | (let ((method1 (cadr method1))) 195 | (cond (restp 196 | 'default-indent) 197 | ((eq method1 'nil) 198 | 'default-indent) 199 | ((integerp method1) 200 | (+ sexp-column method1)) 201 | (t 202 | (compute-indent-symbol-method 203 | method1 path indent-point sexp-column)))))))))))) 204 | 205 | (defun compute-indent-method (method path indent-point sexp-column) 206 | (funcall (etypecase method 207 | (integer #'compute-indent-integer-method) 208 | (symbol #'compute-indent-symbol-method) 209 | (list #'compute-indent-complex-method)) 210 | method path indent-point sexp-column)) 211 | 212 | (defun quote-form-point-p (p) 213 | (and (eql (character-at p -1) #\') 214 | (not (eql (character-at p -2) #\#)))) 215 | 216 | (defun vector-form-point-p (p) 217 | (eql (character-at p -1) #\#)) 218 | 219 | (defun find-indent-method (name path) 220 | (flet ((f (method) 221 | (when method 222 | (return-from find-indent-method method)))) 223 | (f (get-indentation name)) 224 | (let ((name1 (ppcre:scan-to-strings "(?<=:)[^:]+" name))) 225 | (when name1 226 | (f (get-indentation name1))) 227 | (f (and *get-method-function* 228 | (funcall *get-method-function* name))) 229 | (f (and (null (cdr path)) 230 | (ppcre:scan "^(?:with-|without-|within-|do-|def)" (or name1 name)) 231 | '(&lambda &body)))))) 232 | 233 | (defun calc-default-indent (point) 234 | (loop 235 | (unless (form-offset point -1) 236 | (let ((charpos (point-charpos point))) 237 | (form-offset point 1) 238 | (skip-whitespace-forward point t) 239 | (when (end-line-p point) 240 | (line-offset point 0 charpos))) 241 | (return)) 242 | (let ((charpos (point-charpos point))) 243 | (back-to-indentation point) 244 | (when (= charpos (point-charpos point)) 245 | (return)) 246 | (line-offset point 0 charpos))) 247 | (point-column point)) 248 | 249 | (defun calc-indent-1 (indent-point) 250 | (let ((calculated 251 | (with-point ((p indent-point)) 252 | (loop 253 | :named outer 254 | :with path := '() :and sexp-column 255 | :repeat *max-depth* 256 | :do 257 | (loop :for n :from 0 :do 258 | (when (and (< 0 n) (start-line-p p)) 259 | (return-from outer nil)) 260 | (unless (form-offset p -1) 261 | (push n path) 262 | (return))) 263 | (let ((name (string-downcase (symbol-string-at-point p)))) 264 | (unless (scan-lists p -1 1 t) 265 | (return-from outer 'default-indent)) 266 | (unless sexp-column (setf sexp-column (point-column p))) 267 | (when (or (quote-form-point-p p) 268 | (vector-form-point-p p)) 269 | (return-from outer (1+ sexp-column))) 270 | (let ((method (find-indent-method name path))) 271 | (when method 272 | (return-from outer (compute-indent-method method 273 | path 274 | indent-point 275 | sexp-column))))))))) 276 | (if (or (null calculated) 277 | (eq calculated 'default-indent)) 278 | (calc-default-indent indent-point) 279 | calculated))) 280 | 281 | (defun calc-indent (point) 282 | (line-start point) 283 | (if (in-string-p point) 284 | nil 285 | (catch 'drop-out 286 | (calc-indent-1 point)))) 287 | -------------------------------------------------------------------------------- /lem-base/buffer.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-lsp.lem-base) 2 | 3 | (annot:enable-annot-syntax) 4 | 5 | (export '(fundamental-mode 6 | current-buffer 7 | make-buffer 8 | buffer 9 | bufferp 10 | buffer-start-point 11 | buffer-end-point 12 | buffer-name 13 | buffer-version 14 | buffer-modified-p 15 | buffer-read-only-p 16 | buffer-syntax-table 17 | buffer-major-mode 18 | buffer-minor-modes 19 | buffer-mark-p 20 | buffer-mark 21 | buffer-point 22 | buffer-nlines 23 | buffer-enable-undo-p 24 | buffer-enable-undo 25 | buffer-disable-undo 26 | buffer-filename 27 | buffer-directory 28 | buffer-unmark 29 | buffer-mark-cancel 30 | buffer-rename 31 | buffer-undo 32 | buffer-redo 33 | buffer-undo-boundary 34 | buffer-value 35 | buffer-unbound 36 | clear-buffer-variables)) 37 | 38 | (export '(%buffer-keep-binfo 39 | %buffer-clear-keep-binfo)) 40 | 41 | (defparameter +original-buffer-name+ "*tmp*") 42 | 43 | (defclass buffer () 44 | ((name 45 | :initform nil 46 | :initarg :name 47 | :accessor buffer-%name) 48 | (%filename 49 | :initform nil 50 | :initarg :%filename 51 | :accessor buffer-%filename) 52 | (%directory 53 | :initform nil 54 | :initarg :%directory 55 | :accessor buffer-%directory) 56 | (%modified-p 57 | :initform nil 58 | :reader buffer-version 59 | :accessor buffer-%modified-p) 60 | (%enable-undo-p 61 | :initform nil 62 | :initarg :%enable-undo-p 63 | :accessor buffer-%enable-undo-p) 64 | (read-only-p 65 | :initform nil 66 | :initarg :read-only-p 67 | :accessor buffer-read-only-p) 68 | (syntax-table 69 | :initform (fundamental-syntax-table) 70 | :initarg :syntax-table 71 | :accessor buffer-syntax-table) 72 | (major-mode 73 | :initform nil 74 | :initarg :major-mode 75 | :accessor buffer-major-mode) 76 | (minor-modes 77 | :initform nil 78 | :initarg :minor-modes 79 | :accessor buffer-minor-modes) 80 | (start-point 81 | :initform nil 82 | :initarg :start-point 83 | :writer set-buffer-start-point 84 | :reader buffer-start-point) 85 | (end-point 86 | :initform nil 87 | :initarg :end-point 88 | :writer set-buffer-end-point 89 | :reader buffer-end-point) 90 | (mark-p 91 | :initform nil 92 | :initarg :mark-p 93 | :accessor buffer-mark-p) 94 | (mark 95 | :initform nil 96 | :initarg :mark 97 | :accessor buffer-mark) 98 | (point 99 | :initform nil 100 | :initarg :point 101 | :accessor buffer-point) 102 | (keep-binfo 103 | :initform nil 104 | :initarg :keep-binfo 105 | :accessor %buffer-keep-binfo) 106 | (points 107 | :initform nil 108 | :accessor buffer-points) 109 | (nlines 110 | :initform nil 111 | :initarg :nlines 112 | :accessor buffer-nlines) 113 | (undo-size 114 | :initform nil 115 | :initarg :undo-size 116 | :accessor buffer-undo-size) 117 | (undo-stack 118 | :initform nil 119 | :initarg :undo-stack 120 | :accessor buffer-undo-stack) 121 | (redo-stack 122 | :initform nil 123 | :initarg :redo-stack 124 | :accessor buffer-redo-stack) 125 | (external-format 126 | :initform nil 127 | :initarg :external-format 128 | :accessor buffer-external-format) 129 | (last-write-date 130 | :initform nil 131 | :initarg :last-write-date 132 | :accessor buffer-last-write-date) 133 | (variables 134 | :initform nil 135 | :initarg :variables 136 | :accessor buffer-variables)) 137 | (:documentation 138 | @lang(:jp "`buffer`はバッファ名、ファイル名、テキスト、テキストを指す位置等が入った、 139 | 文書を管理するオブジェクトです。 140 | 複数の`buffer`はリストで管理されています。"))) 141 | 142 | (setf (documentation 'buffer-point 'function) @lang(:jp "`buffer`の現在の`point`を返します。")) 143 | (setf (documentation 'buffer-mark 'function) @lang(:jp "`buffer`の現在のマークの`point`を返します。")) 144 | (setf (documentation 'buffer-start-point 'function) @lang(:jp "`buffer`の最初の位置の`point`を返します。")) 145 | (setf (documentation 'buffer-end-point 'function) @lang(:jp "`buffer`の最後の位置の`point`を返します。")) 146 | 147 | (defvar *current-buffer*) 148 | 149 | (defun current-buffer () 150 | @lang(:jp "現在の`buffer`を返します。") 151 | (unless (boundp '*current-buffer*) 152 | (setf *current-buffer* 153 | (get-buffer-create +original-buffer-name+))) 154 | *current-buffer*) 155 | 156 | (defun (setf current-buffer) (buffer) 157 | @lang(:jp "現在の`buffer`を変更します。") 158 | (check-type buffer buffer) 159 | (setf *current-buffer* buffer)) 160 | 161 | (defvar *undo-modes* '(:edit :undo :redo)) 162 | (defvar *undo-mode* :edit) 163 | (defvar *undo-limit* 100000) 164 | 165 | (defun make-buffer (name &key filename read-only-p (enable-undo-p t) 166 | (syntax-table (fundamental-syntax-table))) 167 | "新しい`buffer`を作って返します。 168 | 既に`name`と同じ名前のバッファがある場合はエラーになります。" 169 | (when (get-buffer name) 170 | (error "buffer already exists: ~A" name)) 171 | (let ((buffer (make-instance 'buffer 172 | :name name 173 | :%filename filename 174 | :%directory (when filename (directory-namestring filename)) 175 | :read-only-p read-only-p 176 | :%enable-undo-p enable-undo-p 177 | :major-mode 'fundamental-mode 178 | :syntax-table syntax-table))) 179 | (setf (buffer-mark-p buffer) nil) 180 | (setf (buffer-mark buffer) nil) 181 | (setf (%buffer-keep-binfo buffer) nil) 182 | (setf (buffer-nlines buffer) 1) 183 | (setf (buffer-%modified-p buffer) 0) 184 | (setf (buffer-undo-size buffer) 0) 185 | (setf (buffer-undo-stack buffer) nil) 186 | (setf (buffer-redo-stack buffer) nil) 187 | (setf (buffer-variables buffer) (make-hash-table :test 'equal)) 188 | (let ((line (make-line nil nil ""))) 189 | (set-buffer-start-point (make-point buffer 1 line 0 :kind :right-inserting) 190 | buffer) 191 | (set-buffer-end-point (make-point buffer 1 line 0 192 | :kind :left-inserting) 193 | buffer) 194 | (setf (buffer-point buffer) 195 | (make-point buffer 1 line 0 196 | :kind :left-inserting))) 197 | (add-buffer buffer) 198 | buffer)) 199 | 200 | (defun bufferp (x) 201 | @lang(:jp "`x`が`buffer`ならT、それ以外ならNILを返します。") 202 | (typep x 'buffer)) 203 | 204 | (defun buffer-modified-p (&optional (buffer (current-buffer))) 205 | @lang(:jp "`buffer`が変更されていたらT、それ以外ならNILを返します。") 206 | (/= 0 (buffer-%modified-p buffer))) 207 | 208 | (defun buffer-enable-undo-p (&optional (buffer (current-buffer))) 209 | @lang(:jp "`buffer`でアンドゥが有効ならT、それ以外ならNILを返します。") 210 | (buffer-%enable-undo-p buffer)) 211 | 212 | (defun buffer-enable-undo (buffer) 213 | @lang(:jp "`buffer`のアンドゥを有効にします。") 214 | (setf (buffer-%enable-undo-p buffer) t) 215 | nil) 216 | 217 | (defun buffer-disable-undo (buffer) 218 | @lang(:jp "`buffer`のアンドゥを無効にしてアンドゥ用の情報を空にします。") 219 | (setf (buffer-%enable-undo-p buffer) nil) 220 | (setf (buffer-undo-size buffer) 0) 221 | (setf (buffer-undo-stack buffer) nil) 222 | (setf (buffer-redo-stack buffer) nil) 223 | nil) 224 | 225 | (defmethod print-object ((buffer buffer) stream) 226 | (format stream "#" 227 | (buffer-name buffer) 228 | (buffer-filename buffer))) 229 | 230 | (defun %buffer-clear-keep-binfo (buffer) 231 | (when (%buffer-keep-binfo buffer) 232 | (destructuring-bind (view-point point) 233 | (%buffer-keep-binfo buffer) 234 | (delete-point view-point) 235 | (delete-point point)))) 236 | 237 | (defun buffer-free (buffer) 238 | (%buffer-clear-keep-binfo buffer) 239 | (delete-point (buffer-point buffer))) 240 | 241 | (defun buffer-name (&optional (buffer (current-buffer))) 242 | @lang(:jp "`buffer`の名前を返します。") 243 | (buffer-%name buffer)) 244 | 245 | (defun buffer-filename (&optional (buffer (current-buffer))) 246 | @lang(:jp "`buffer`のファイル名を返します。") 247 | (buffer-%filename buffer)) 248 | 249 | (defun (setf buffer-filename) (filename &optional (buffer (current-buffer))) 250 | (setf (buffer-%filename buffer) filename)) 251 | 252 | (defun buffer-directory (&optional (buffer (current-buffer))) 253 | @lang(:jp "`buffer`のディレクトリを返します。") 254 | (or (buffer-%directory buffer) 255 | (namestring (uiop:getcwd)))) 256 | 257 | (defun (setf buffer-directory) (directory &optional (buffer (current-buffer))) 258 | (let ((result (uiop:directory-exists-p directory))) 259 | (unless result 260 | (error "directory does not exist: ~A" directory)) 261 | (setf (buffer-%directory buffer) 262 | (namestring result)))) 263 | 264 | (defun buffer-unmark (buffer) 265 | @lang(:jp "`buffer`の変更フラグを下ろします。") 266 | (setf (buffer-%modified-p buffer) 0)) 267 | 268 | (defun buffer-mark-cancel (buffer) 269 | (when (buffer-mark-p buffer) 270 | (setf (buffer-mark-p buffer) nil) 271 | t)) 272 | 273 | (defun check-read-only-buffer (buffer) 274 | (when (buffer-read-only-p buffer) 275 | (error 'read-only-error))) 276 | 277 | (defun buffer-modify (buffer) 278 | (ecase *undo-mode* 279 | ((:edit :redo) 280 | (incf (buffer-%modified-p buffer))) 281 | ((:undo) 282 | (decf (buffer-%modified-p buffer)))) 283 | (buffer-mark-cancel buffer)) 284 | 285 | (defun push-undo-stack (buffer elt) 286 | (cond ((<= (+ *undo-limit* (floor (* *undo-limit* 0.3))) 287 | (buffer-undo-size buffer)) 288 | (setf (buffer-undo-stack buffer) 289 | (subseq (buffer-undo-stack buffer) 290 | 0 291 | *undo-limit*)) 292 | (setf (buffer-undo-size buffer) 293 | (1+ (length (buffer-undo-stack buffer))))) 294 | (t 295 | (incf (buffer-undo-size buffer)))) 296 | (push elt (buffer-undo-stack buffer))) 297 | 298 | (defun push-redo-stack (buffer elt) 299 | (push elt (buffer-redo-stack buffer))) 300 | 301 | (defun push-undo (buffer fn) 302 | (when (and (buffer-enable-undo-p buffer) 303 | (not (ghost-buffer-p buffer))) 304 | (ecase *undo-mode* 305 | (:edit 306 | (push-undo-stack buffer fn) 307 | (setf (buffer-redo-stack buffer) nil)) 308 | (:redo 309 | (push-undo-stack buffer fn)) 310 | (:undo 311 | (push-redo-stack buffer fn))))) 312 | 313 | (defun buffer-rename (buffer name) 314 | @lang(:jp "`buffer`の名前を`name`に変更します。") 315 | (check-type buffer buffer) 316 | (check-type name string) 317 | (when (get-buffer name) 318 | (editor-error "Buffer name `~A' is in use" name)) 319 | (setf (buffer-%name buffer) name)) 320 | 321 | (defun buffer-undo-1 (point) 322 | (let* ((buffer (point-buffer point)) 323 | (elt (pop (buffer-undo-stack buffer)))) 324 | (when elt 325 | (let ((*undo-mode* :undo)) 326 | (unless (eq elt :separator) 327 | (decf (buffer-undo-size buffer)) 328 | (funcall elt point)))))) 329 | 330 | (defun buffer-undo (point) 331 | (let ((buffer (point-buffer point))) 332 | (push :separator (buffer-redo-stack buffer)) 333 | (when (eq :separator (car (buffer-undo-stack buffer))) 334 | (pop (buffer-undo-stack buffer))) 335 | (let ((result0 nil)) 336 | (loop :for result := (buffer-undo-1 point) 337 | :while result 338 | :do (setf result0 result)) 339 | (unless result0 340 | (assert (eq :separator (car (buffer-redo-stack buffer)))) 341 | (pop (buffer-redo-stack buffer))) 342 | result0))) 343 | 344 | (defun buffer-redo-1 (point) 345 | (let* ((buffer (point-buffer point)) 346 | (elt (pop (buffer-redo-stack buffer)))) 347 | (when elt 348 | (let ((*undo-mode* :redo)) 349 | (unless (eq elt :separator) 350 | (funcall elt point)))))) 351 | 352 | (defun buffer-redo (point) 353 | (let ((buffer (point-buffer point))) 354 | (push :separator (buffer-undo-stack buffer)) 355 | (let ((result0 nil)) 356 | (loop :for result := (buffer-redo-1 point) 357 | :while result 358 | :do (setf result0 result)) 359 | (unless result0 360 | (assert (eq :separator (car (buffer-undo-stack buffer)))) 361 | (pop (buffer-undo-stack buffer))) 362 | result0))) 363 | 364 | (defun buffer-undo-boundary (&optional (buffer (current-buffer))) 365 | (unless (eq :separator (car (buffer-undo-stack buffer))) 366 | (push :separator (buffer-undo-stack buffer)))) 367 | 368 | (defun buffer-value (buffer name &optional default) 369 | @lang(:jp "`buffer`のバッファ変数`name`に束縛されている値を返します。 370 | `buffer`の型は`buffer`または`point`です。 371 | 変数が設定されていない場合は`default`を返します。") 372 | (setf buffer (ensure-buffer buffer)) 373 | (multiple-value-bind (value foundp) 374 | (gethash name (buffer-variables buffer)) 375 | (if foundp value default))) 376 | 377 | (defun (setf buffer-value) (value buffer name &optional default) 378 | @lang(:jp "`buffer`のバッファ変数`name`に`value`を束縛します。 379 | `buffer`の型は`buffer`または`point`です。") 380 | (declare (ignore default)) 381 | (setf buffer (ensure-buffer buffer)) 382 | (setf (gethash name (buffer-variables buffer)) value)) 383 | 384 | (defun buffer-unbound (buffer name) 385 | @lang(:jp "`buffer`のバッファ変数`name`の束縛を消します。") 386 | (remhash name (buffer-variables buffer))) 387 | 388 | (defun clear-buffer-variables (&key (buffer (current-buffer))) 389 | @lang(:jp "`buffer`に束縛されているすべてのバッファ変数を消します。") 390 | (clrhash (buffer-variables buffer))) 391 | -------------------------------------------------------------------------------- /lem-base/buffer-insert.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-lsp.lem-base) 2 | 3 | (export '(*inhibit-read-only* 4 | *inhibit-modification-hooks* 5 | before-change-functions 6 | after-change-functions)) 7 | 8 | (defvar *inhibit-read-only* nil) 9 | (defvar *inhibit-modification-hooks* nil) 10 | 11 | (define-editor-variable before-change-functions '()) 12 | (define-editor-variable after-change-functions '()) 13 | 14 | (defun check-read-only-at-point (point offset) 15 | (unless *inhibit-read-only* 16 | (let ((line (point-line point)) 17 | (charpos (point-charpos point))) 18 | (when (if (eql offset 0) 19 | (line-search-property line :read-only charpos) 20 | (line-search-property-range line 21 | :read-only 22 | charpos 23 | (if (null offset) 24 | nil 25 | (+ charpos offset)))) 26 | (error 'read-only-error))))) 27 | 28 | (defmacro with-modify-buffer (buffer &body body) 29 | (alexandria:once-only (buffer) 30 | `(without-interrupts 31 | (unless *inhibit-read-only* 32 | (check-read-only-buffer ,buffer)) 33 | (prog1 (progn ,@body) 34 | (buffer-modify ,buffer))))) 35 | 36 | (defun line-next-n (line n) 37 | (loop :repeat n 38 | :do (setf line (line-next line))) 39 | line) 40 | 41 | (defun shift-markers (point offset-line offset-char) 42 | (cond ((and (= 0 offset-line) 43 | (< 0 offset-char)) 44 | (let ((charpos (point-charpos point))) 45 | (dolist (p (line-points (point-line point))) 46 | (when (etypecase (point-kind p) 47 | ((eql :left-inserting) 48 | (<= charpos (point-charpos p))) 49 | ((eql :right-inserting) 50 | (< charpos (point-charpos p)))) 51 | (incf (point-charpos p) offset-char))))) 52 | ((< 0 offset-line) 53 | (let ((linum (point-linum point)) 54 | (charpos (point-charpos point)) 55 | (line (line-next-n (point-line point) offset-line))) 56 | (dolist (p (buffer-points (point-buffer point))) 57 | (cond ((and (= linum (point-linum p)) 58 | (etypecase (point-kind p) 59 | ((eql :left-inserting) 60 | (<= charpos (point-charpos p))) 61 | ((eql :right-inserting) 62 | (< charpos (point-charpos p))))) 63 | (incf (point-linum p) offset-line) 64 | (decf (point-charpos p) charpos) 65 | (incf (point-charpos p) offset-char) 66 | (point-change-line p (+ linum offset-line) line)) 67 | ((< linum (point-linum p)) 68 | (incf (point-linum p) offset-line)))))) 69 | ((and (= 0 offset-line) 70 | (> 0 offset-char)) 71 | (let ((charpos (point-charpos point)) 72 | (n (- offset-char))) 73 | (dolist (p (line-points (point-line point))) 74 | (when (< charpos (point-charpos p)) 75 | (setf (point-charpos p) 76 | (if (> charpos (- (point-charpos p) n)) 77 | charpos 78 | (- (point-charpos p) n))))))) 79 | ((> 0 offset-line) 80 | (let ((linum (point-linum point)) 81 | (charpos (point-charpos point)) 82 | (line (point-line point)) 83 | (offset-line (abs offset-line)) 84 | (offset-char (abs offset-char))) 85 | (dolist (p (buffer-points (point-buffer point))) 86 | (when (<= linum (point-linum p)) 87 | (cond ((<= (- (point-linum p) offset-line) 88 | linum) 89 | (setf (point-charpos p) 90 | (if (= (- (point-linum p) offset-line) 91 | linum) 92 | (+ charpos (max 0 (- (point-charpos p) offset-char))) 93 | charpos)) 94 | (point-change-line p linum line) 95 | (setf (point-linum p) linum)) 96 | (t 97 | (decf (point-linum p) offset-line))))))))) 98 | 99 | (defun %insert-newline/point (buffer line charpos) 100 | (make-line line 101 | (line-next line) 102 | (subseq (line-str line) charpos)) 103 | (line-property-insert-newline line (line-next line) charpos) 104 | (incf (buffer-nlines buffer)) 105 | (setf (line-str line) 106 | (subseq (line-str line) 0 charpos))) 107 | 108 | (defgeneric insert-char/point (point char) 109 | (:method (point char) 110 | (with-modify-buffer (point-buffer point) 111 | (check-read-only-at-point point 0) 112 | (cond 113 | ((char= char #\newline) 114 | (%insert-newline/point (point-buffer point) 115 | (point-line point) 116 | (point-charpos point)) 117 | (shift-markers point 1 0)) 118 | (t 119 | (let ((line (point-line point)) 120 | (charpos (point-charpos point))) 121 | (line-property-insert-pos line charpos 1) 122 | (shift-markers point 0 1) 123 | (setf (line-str line) 124 | (concatenate 'string 125 | (subseq (line-str line) 0 charpos) 126 | (string char) 127 | (subseq (line-str line) charpos)))))) 128 | char))) 129 | 130 | (defun %insert-line-string/point (line charpos string) 131 | (line-property-insert-pos line charpos (length string)) 132 | (setf (line-str line) 133 | (concatenate 'string 134 | (subseq (line-str line) 0 charpos) 135 | string 136 | (subseq (line-str line) charpos)))) 137 | 138 | (defgeneric insert-string/point (point string) 139 | (:method (point string) 140 | (let ((buffer (point-buffer point))) 141 | (with-modify-buffer buffer 142 | (check-read-only-at-point point 0) 143 | (loop :with start := 0 144 | :for pos := (position #\newline string :start start) 145 | :for line := (point-line point) :then (line-next line) 146 | :for charpos := (point-charpos point) :then 0 147 | :for offset-line :from 0 148 | :do (cond ((null pos) 149 | (let ((substr (if (= start 0) string (subseq string start)))) 150 | (%insert-line-string/point line charpos substr) 151 | (shift-markers point offset-line (length substr))) 152 | (return)) 153 | (t 154 | (let ((substr (subseq string start pos))) 155 | (%insert-line-string/point line charpos substr) 156 | (%insert-newline/point buffer 157 | line 158 | (+ charpos (length substr))) 159 | (setf start (1+ pos)))))))) 160 | string)) 161 | 162 | (defun %delete-line-between/point (point start end) 163 | (declare (special killring-stream line)) 164 | (line-property-delete-pos (point-line point) 165 | (point-charpos point) 166 | (- end start)) 167 | (write-string (line-str line) killring-stream 168 | :start start 169 | :end end) 170 | (setf (line-str line) 171 | (concatenate 'string 172 | (subseq (line-str line) 0 start) 173 | (subseq (line-str line) end)))) 174 | 175 | (defun %delete-line-eol/point (point start) 176 | (declare (special killring-stream line)) 177 | (line-property-delete-line (point-line point) (point-charpos point)) 178 | (write-string (line-str line) killring-stream :start start) 179 | (setf (line-str line) 180 | (subseq (line-str line) 0 start))) 181 | 182 | (defun %delete-line/point (point start) 183 | (declare (special killring-stream line buffer n)) 184 | (line-property-delete-line (point-line point) (point-charpos point)) 185 | (write-string (line-str line) killring-stream :start start) 186 | (write-char #\newline killring-stream) 187 | (unless (eq n 'T) 188 | (decf n (1+ (- (line-length line) start)))) 189 | (decf (buffer-nlines buffer)) 190 | (setf (line-str line) 191 | (concatenate 'string 192 | (subseq (line-str line) 0 start) 193 | (line-str (line-next line)))) 194 | (line-free (line-next line))) 195 | 196 | (defgeneric delete-char/point (point n) 197 | (:method (point n) 198 | (declare (special n)) 199 | (with-modify-buffer (point-buffer point) 200 | (with-output-to-string (killring-stream) 201 | (declare (special killring-stream)) 202 | (let ((charpos (point-charpos point)) 203 | (buffer (point-buffer point)) 204 | (line (point-line point)) 205 | (offset-line 0)) 206 | (declare (special buffer line)) 207 | (loop :while (or (eq n 'T) (plusp n)) 208 | :for eolp := (or (eq n 'T) 209 | (> n (- (line-length line) charpos))) 210 | :do 211 | (check-read-only-at-point point (if (eq n 'T) nil (if eolp n nil))) 212 | (cond 213 | ((not eolp) 214 | (%delete-line-between/point point charpos (+ charpos n)) 215 | (shift-markers point offset-line (- n)) 216 | (return)) 217 | ((null (line-next line)) 218 | (%delete-line-eol/point point charpos) 219 | (shift-markers point offset-line (- charpos (line-length line))) 220 | (return)) 221 | (t 222 | (%delete-line/point point charpos))) 223 | (decf offset-line) 224 | :finally (shift-markers point offset-line 0))))))) 225 | 226 | 227 | (declaim (inline call-before-change-functions 228 | call-after-change-functions)) 229 | 230 | (defun call-before-change-functions (buffer start n) 231 | (unless *inhibit-modification-hooks* 232 | (alexandria:when-let ((hooks (variable-value 'before-change-functions :buffer buffer))) 233 | (run-hooks hooks start n)) 234 | (alexandria:when-let ((hooks (variable-value 'before-change-functions :global))) 235 | (run-hooks hooks start n)))) 236 | 237 | (defun call-after-change-functions (buffer start end old-len) 238 | (unless *inhibit-modification-hooks* 239 | (alexandria:when-let ((hooks (variable-value 'after-change-functions :buffer buffer))) 240 | (run-hooks hooks start end old-len)) 241 | (alexandria:when-let ((hooks (variable-value 'after-change-functions :global))) 242 | (run-hooks hooks start end old-len)))) 243 | 244 | (defmacro insert/after-change-function (point arg) 245 | `(if (and (not *inhibit-modification-hooks*) 246 | (variable-value 'after-change-functions)) 247 | (with-point ((start ,point)) 248 | (prog1 (call-next-method) 249 | (with-point ((end start)) 250 | (character-offset end ,arg) 251 | (call-after-change-functions (point-buffer ,point) start end 0)))) 252 | (call-next-method))) 253 | 254 | (defmacro delete/after-change-function (point) 255 | `(if (and (not *inhibit-modification-hooks*) 256 | (variable-value 'after-change-functions)) 257 | (let ((string (call-next-method))) 258 | (with-point ((start ,point) 259 | (end ,point)) 260 | (call-after-change-functions (point-buffer ,point) start end (length string))) 261 | string) 262 | (call-next-method))) 263 | 264 | (defmethod insert-char/point :around (point char) 265 | (call-before-change-functions (point-buffer point) point 1) 266 | (if (not (buffer-enable-undo-p (point-buffer point))) 267 | (insert/after-change-function point 1) 268 | (let ((linum (line-number-at-point point)) 269 | (charpos (point-charpos point))) 270 | (prog1 (insert/after-change-function point 1) 271 | (push-undo (point-buffer point) 272 | (lambda (cur-point) 273 | (move-to-line cur-point linum) 274 | (line-offset cur-point 0 charpos) 275 | (delete-char/point cur-point 1) 276 | t)))))) 277 | 278 | (defmethod insert-string/point :around (point string) 279 | (call-before-change-functions (point-buffer point) point (length string)) 280 | (if (not (buffer-enable-undo-p (point-buffer point))) 281 | (insert/after-change-function point (length string)) 282 | (let ((linum (line-number-at-point point)) 283 | (charpos (point-charpos point))) 284 | (prog1 (insert/after-change-function point (length string)) 285 | (push-undo (point-buffer point) 286 | (lambda (cur-point) 287 | (move-to-line cur-point linum) 288 | (line-offset cur-point 0 charpos) 289 | (delete-char/point cur-point (length string)) 290 | t)))))) 291 | 292 | (defmethod delete-char/point :around (point n) 293 | (call-before-change-functions (point-buffer point) point (- n)) 294 | (if (not (buffer-enable-undo-p (point-buffer point))) 295 | (delete/after-change-function point) 296 | (let ((linum (line-number-at-point point)) 297 | (charpos (point-charpos point)) 298 | (string (delete/after-change-function point))) 299 | (push-undo (point-buffer point) 300 | (lambda (cur-point) 301 | (move-to-line cur-point linum) 302 | (line-offset cur-point 0 charpos) 303 | (insert-string/point cur-point string) 304 | t)) 305 | string))) 306 | -------------------------------------------------------------------------------- /protocol.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-lsp/protocol 2 | (:use :cl) 3 | (:export :convert-from-hash-table 4 | :convert-to-hash-table)) 5 | (in-package :cl-lsp/protocol) 6 | 7 | (defvar null-slot-value (make-symbol "NULL")) 8 | 9 | (defvar *protocol-symbols* '()) 10 | 11 | (defclass protocol () ()) 12 | 13 | (defmacro define-interface (name parent &body slots) 14 | `(progn 15 | (push ',name *protocol-symbols*) 16 | (export ',(cons name (mapcar #'first slots))) 17 | (defclass ,name ,(if (null parent) 18 | `(protocol) 19 | parent) 20 | ,(mapcar (lambda (slot) 21 | (let ((slot-symbol (first slot)) 22 | (type (getf (rest slot) :type)) 23 | (optional (getf (rest slot) :optional)) 24 | (documentation (getf (rest slot) :documentation))) 25 | `(,slot-symbol 26 | :initarg ,(intern (string slot-symbol) :keyword) 27 | ,@(if type 28 | `(:type ,type)) 29 | ,@(if optional 30 | `(:initform null-slot-value)) 31 | ,@(if documentation 32 | `(:documentation ,documentation))))) 33 | slots)))) 34 | 35 | (deftype |DocumentUri| () 'string) 36 | 37 | (define-interface |Position| () 38 | (|line| :type number) 39 | (|character| :type number)) 40 | 41 | (define-interface |Range| () 42 | (|start| :type |Position|) 43 | (|end| :type |Position|)) 44 | 45 | (define-interface |Location| () 46 | (|uri| :type |DocumentUri|) 47 | (|range| :type |Range|)) 48 | 49 | (define-interface |Diagnostic| () 50 | (|range| :type |Range|) 51 | (|severity| :optional t :type (or null number)) 52 | (|code| :optional t :type (or null number string)) 53 | (|source| :optional t :type (or null string)) 54 | (|message| :type string)) 55 | 56 | (export (defparameter |DiagnosticSeverity.Error| 1)) 57 | (export (defparameter |DiagnosticSeverity.Warning| 2)) 58 | (export (defparameter |DiagnosticSeverity.Information| 3)) 59 | (export (defparameter |DiagnosticSeverity.Hint| 4)) 60 | 61 | (define-interface |Command| () 62 | (|title| :type string) 63 | (|command| :type string) 64 | (|arguments| :type list)) 65 | 66 | (define-interface |TextEdit| () 67 | (|range| :type |Range|) 68 | (|newText| :type string)) 69 | 70 | (define-interface |TextDocumentEdit| () 71 | (|textDocument| :type |VersionedTextDocumentIdentifier|) 72 | (|edits| :type (trivial-types:proper-list |TextEdit|))) 73 | 74 | (define-interface |WorkspaceEdit| () 75 | (|changes| :optional t) 76 | (|documentChanges| :optional t :type (trivial-types:proper-list |TextDocumentEdit|))) 77 | 78 | (define-interface |TextDocumentIdentifier| () 79 | (|uri| :type |DocumentUri|)) 80 | 81 | (define-interface |TextDocumentItem| () 82 | (|uri| :type |DocumentUri|) 83 | (|languageId| :type string) 84 | (|version| :type number) 85 | (|text| :type string)) 86 | 87 | (define-interface |VersionedTextDocumentIdentifier| 88 | (|TextDocumentIdentifier|) 89 | (|version| :type number)) 90 | 91 | (define-interface |TextDocumentPositionParams| () 92 | (|textDocument| :type |TextDocumentIdentifier|) 93 | (|position| :type |Position|)) 94 | 95 | (define-interface |DocumentFilter| () 96 | (|language| :optional t :type string) 97 | (|scheme| :optional t :type string) 98 | (|pattern| :optional t :type string)) 99 | 100 | (deftype |DocumentSelector| () 101 | '(trivial-types:proper-list |DocumentFilter|)) 102 | 103 | (define-interface |InitializeParams| () 104 | (|processId| :type (or number null)) 105 | (|rootPath| :type (or string null)) 106 | (|rootUri| :type (or |DocumentUri| null)) 107 | (|initializationOptions| :optional t) 108 | (|capabilities| :type |ClientCapabilities|) 109 | (|trace| :optional t)) 110 | 111 | (define-interface |WorkspaceClientCapabilites| () 112 | (|applyEdit| :optional t :type boolean) 113 | (|didChangeConfiguration| :optional t) 114 | (|didChangeWatchedFiles| :optional t) 115 | (|symbol| :optional t) 116 | (|executeCommand| :optional t)) 117 | 118 | (define-interface |TextDocumentClientCapabilities| () 119 | (|synchronization| :optional t) 120 | (|completion| :optional t) 121 | (|hover| :optional t) 122 | (|signatureHelp| :optional t) 123 | (|references| :optional t) 124 | (|documentHighlight| :optional t) 125 | (|documentSymbol| :optional t) 126 | (|formatting| :optional t) 127 | (|rangeFormatting| :optional t) 128 | (|onTypeFormatting| :optional t) 129 | (|definition| :optional t) 130 | (|codeAction| :optional t) 131 | (|codeLens| :optional t) 132 | (|documentLink| :optional t) 133 | (|rename| :optional t)) 134 | 135 | (define-interface |ClientCapabilities| () 136 | (|workspace| :optional t :type |WorkspaceClientCapabilites|) 137 | (|textDocument| :optional t :type |TextDocumentClientCapabilities|) 138 | (|experimental| :optional t :type t)) 139 | 140 | (define-interface |InitializeResult| () 141 | (|capabilities| :type |ServerCapabilities|)) 142 | 143 | (define-interface |InitializeError| () 144 | (|retry| :type boolean)) 145 | 146 | (export (defparameter |TextDocumentSyncKind.None| 0)) 147 | (export (defparameter |TextDocumentSyncKind.Full| 1)) 148 | (export (defparameter |TextDocumentSyncKind.Incremental| 2)) 149 | 150 | (define-interface |CompletionOptions| () 151 | (|resolveProvider| :optional t :type boolean) 152 | (|triggerCharacters| :optional t :type (trivial-types:proper-list string))) 153 | 154 | (define-interface |SignatureHelpOptions| () 155 | (|triggerCharacters| :optional t :type (trivial-types:proper-list string))) 156 | 157 | (define-interface |CodeLensOptions| () 158 | (|resolveProvider| :optional t :type boolean)) 159 | 160 | (define-interface |DocumentOnTypeFormattingOptions| () 161 | (|firstTriggerCharacter| :type string) 162 | (|moreTriggerCharacter| :optional t :type (trivial-types:proper-list string))) 163 | 164 | (define-interface |DocumentLinkOptions| () 165 | (|resolveProvider| :optional t :type boolean)) 166 | 167 | (define-interface |ExecuteCommandOptions| () 168 | (|commands| :type (trivial-types:proper-list string))) 169 | 170 | (define-interface |SaveOptions| () 171 | (|includeText| :optional t :type boolean)) 172 | 173 | (define-interface |TextDocumentSyncOptions| () 174 | (|openClose| :optional t :type boolean) 175 | (|change| :optional t :type number) 176 | (|willSave| :optional t :type boolean) 177 | (|willSaveWaitUntil| :optional t :type boolean) 178 | (|save| :optional t :type |SaveOptions|)) 179 | 180 | (define-interface |ServerCapabilities| () 181 | (|textDocumentSync| :optional t :type (or |TextDocumentSyncOptions| number)) 182 | (|hoverProvider| :optional t :type boolean) 183 | (|completionProvider| :optional t :type |CompletionOptions|) 184 | (|signatureHelpProvider| :optional t :type |SignatureHelpOptions|) 185 | (|definitionProvider| :optional t :type boolean) 186 | (|referencesProvider| :optional t :type boolean) 187 | (|documentHighlightProvider| :optional t :type boolean) 188 | (|documentSymbolProvider| :optional t :type boolean) 189 | (|workspaceSymbolProvider| :optional t :type boolean) 190 | (|codeActionProvider| :optional t :type boolean) 191 | (|codeLensProvider| :optional t :type |CodeLensOptions|) 192 | (|documentFormattingProvider| :optional t :type boolean) 193 | (|documentRangeFormattingProvider| :optional t :type boolean) 194 | (|documentOnTypeFormattingProvider| :optional t :type |DocumentOnTypeFormattingOptions|) 195 | (|renameProvider| :optional t :type boolean) 196 | (|documentLinkProvider| :optional t :type |DocumentLinkOptions|) 197 | (|executeCommandProvider| :optional t :type |ExecuteCommandOptions|) 198 | (|experimental| :optional t :type t)) 199 | 200 | (define-interface |ShowMessageParams| () 201 | (|type| :type number) 202 | (|message| :type string)) 203 | 204 | (export (defparameter |MessageType.Error| 1)) 205 | (export (defparameter |MessageType.Warning| 2)) 206 | (export (defparameter |MessageType.Info| 3)) 207 | (export (defparameter |MessageType.Log| 4)) 208 | 209 | (define-interface |ShowMessageRequestParams| () 210 | (|type| :type number) 211 | (|message| :type string) 212 | (|actions| :optional t :type (trivial-types:proper-list |MessageActionItem|))) 213 | 214 | (define-interface |MessageActionItem| () 215 | (|title| :type string)) 216 | 217 | (define-interface |LogMessageParams| () 218 | (|type| :type number) 219 | (|message| :type string)) 220 | 221 | (define-interface |Registration| () 222 | (|id| :type string) 223 | (|method| :type string) 224 | (|registerOptions| :optional t)) 225 | 226 | (define-interface |RegistrationParams| () 227 | (|registrations| :type (trivial-types:proper-list |Registration|))) 228 | 229 | (define-interface |TextDocumentRegistrationOptions| () 230 | (|documentSelector| :type (or |DocumentSelector| |null|))) 231 | 232 | (define-interface |TextDocumentChangeRegistrationOptions| (|TextDocumentRegistrationOptions|) 233 | (|syncKind| :type number)) 234 | 235 | (define-interface |Unregistration| () 236 | (|id| :type string) 237 | (|method| :type string)) 238 | 239 | (define-interface |UnregistrationParams| () 240 | (|unregisterations| :type (trivial-types:proper-list |Unregistration|))) 241 | 242 | (define-interface |DidOpenTextDocumentParams| () 243 | (|textDocument| :type |TextDocumentItem|)) 244 | 245 | (define-interface |DidChangeTextDocumentParams| () 246 | (|textDocument| :type |VersionedTextDocumentIdentifier|) 247 | (|contentChanges| :type (trivial-types:proper-list |TextDocumentContentChangeEvent|))) 248 | 249 | (define-interface |TextDocumentContentChangeEvent| () 250 | (|range| :optional t :type |Range|) 251 | (|rangeLength| :optional t :type number) 252 | (|text| :type string)) 253 | 254 | (define-interface |DidSaveTextDocumentParams| () 255 | (|textDocument| :type |TextDocumentIdentifier|) 256 | (|text| :optional t :type string)) 257 | 258 | (define-interface |DidCloseTextDocumentParams| () 259 | (|textDocument| :type |TextDocumentIdentifier|)) 260 | 261 | (define-interface |PublishDiagnosticsParams| () 262 | (|uri| :type |DocumentUri|) 263 | (|diagnostics| :type (trivial-types:proper-list |Diagnostic|))) 264 | 265 | (define-interface |CompletionList| () 266 | (|isIncomplete| :type boolean) 267 | (|items| :type (trivial-types:proper-list |CompletionItem|))) 268 | 269 | (define-interface |CompletionItem| () 270 | (|label| :type string) 271 | (|kind| :optional t :type number) 272 | (|detail| :optional t :type string) 273 | (|documentation| :optional t :type string) 274 | (|sortText| :optional t :type string) 275 | (|filterText| :optional t :type string) 276 | (|insertText| :optional t :type string) 277 | (|insertTextFormat| :optional t :type |InsertTextFormat|) 278 | (|textEdit| :optional t :type |TextEdit|) 279 | (|additionalTextEdits| :optional t :type (trivial-types:proper-list |TextEdit|)) 280 | (|command| :optional t :type |Command|) 281 | (|data| :optional t :type t)) 282 | 283 | (define-interface |Hover| () 284 | (|contents| :type t) 285 | (|range| :optional t :type |Range|)) 286 | 287 | (define-interface |SignatureHelp| () 288 | (|signatures| :type (trivial-types:proper-list |SignatureInformation|)) 289 | (|activeSignature| :optional t :type number) 290 | (|activeParameter| :optional t :type number)) 291 | 292 | (define-interface |SignatureInformation| () 293 | (|label| :type string) 294 | (|documentation| :optional t :type string) 295 | (|parameters| :optional t :type (trivial-types:proper-list |ParameterInformation|))) 296 | 297 | (define-interface |ParameterInformation| () 298 | (|label| :type string) 299 | (|documentation| :optional t :type string)) 300 | 301 | (define-interface |ReferenceParams| (|TextDocumentPositionParams|) 302 | (|context| :type |ReferenceContext|)) 303 | 304 | (define-interface |ReferenceContext| () 305 | (|includeDeclaration| :type boolean)) 306 | 307 | (define-interface |DocumentHighlight| () 308 | (|range| :type |Range|) 309 | (|kind| :optional t :type number)) 310 | 311 | (export (defparameter |DocumentHighlightKind.Text| 1)) 312 | (export (defparameter |DocumentHighlightKind.Read| 2)) 313 | (export (defparameter |DocumentHighlightKind.Write| 3)) 314 | 315 | (define-interface |DocumentSymbolParams| () 316 | (|textDocument| :type |TextDocumentIdentifier|)) 317 | 318 | (define-interface |SymbolInformation| () 319 | (|name| :type string) 320 | (|kind| :type number) 321 | (|location| :type |Location|) 322 | (|containerName| :optional t :type string)) 323 | 324 | (export (defparameter |SymbolKind.File| 1)) 325 | (export (defparameter |SymbolKind.Module| 2)) 326 | (export (defparameter |SymbolKind.Namespace| 3)) 327 | (export (defparameter |SymbolKind.Package| 4)) 328 | (export (defparameter |SymbolKind.Class| 5)) 329 | (export (defparameter |SymbolKind.Method| 6)) 330 | (export (defparameter |SymbolKind.Property| 7)) 331 | (export (defparameter |SymbolKind.Field| 8)) 332 | (export (defparameter |SymbolKind.Constructor| 9)) 333 | (export (defparameter |SymbolKind.Enum| 10)) 334 | (export (defparameter |SymbolKind.Interface| 11)) 335 | (export (defparameter |SymbolKind.Function| 12)) 336 | (export (defparameter |SymbolKind.Variable| 13)) 337 | (export (defparameter |SymbolKind.Constant| 14)) 338 | (export (defparameter |SymbolKind.String| 15)) 339 | (export (defparameter |SymbolKind.Number| 16)) 340 | (export (defparameter |SymbolKind.Boolean| 17)) 341 | (export (defparameter |SymbolKind.Array| 18)) 342 | 343 | (define-interface |WorkspaceSymbolParams| () 344 | (|query| :type string)) 345 | 346 | (define-interface |CodeLensParams| () 347 | (|textDocument| :type |TextDocumentIdentifier|)) 348 | 349 | (define-interface |CodeLens| () 350 | (|range| :type |Range|) 351 | (|command| :optional t :type |Command|) 352 | (|data| :optional t :type t)) 353 | 354 | (define-interface |DocumentLinkParams| () 355 | (|textDocument| :type |TextDocumentIdentifier|)) 356 | 357 | (define-interface |DocumentLink| () 358 | (|range| :type |Range|) 359 | (|target| :optional t :type |DocumentUri|)) 360 | 361 | (define-interface |DocumentFormattingParams| () 362 | (|textDocument| :type |TextDocumentIdentifier|) 363 | (|options| :type |FormattingOptions|)) 364 | 365 | (define-interface |FormattingOptions| () 366 | (|tabSize| :type number) 367 | (|insertSpaces| :type boolean) 368 | ;; [key: string]: boolean | number | string; 369 | ) 370 | 371 | (define-interface |DocumentRangeFormattingParams| () 372 | (|textDocument| :type |TextDocumentIdentifier|) 373 | (|range| :type |Range|) 374 | (|options| :type |FormattingOptions|)) 375 | 376 | (define-interface |DocumentOnTypeFormattingParams| () 377 | (|textDocument| :type |TextDocumentIdentifier|) 378 | (|position| :type |Position|) 379 | (|ch| :type string) 380 | (|options| :type |FormattingOptions|)) 381 | 382 | (define-interface |RenameParams| () 383 | (|textDocument| :type |TextDocumentIdentifier|) 384 | (|position| :type |Position|) 385 | (|newName| :type string)) 386 | 387 | (defun protocol-symbol-p (type) 388 | (when (member type *protocol-symbols*) 389 | type)) 390 | 391 | (defun protocol-list-p (type) 392 | (and (consp type) 393 | (eq 'trivial-types:proper-list (car type)) 394 | (protocol-symbol-p (second type)))) 395 | 396 | (defun maybe-protocol-type (type hash-value) 397 | (cond ((and (symbolp type) 398 | (protocol-symbol-p type) 399 | (hash-table-p hash-value)) 400 | (convert-from-hash-table type hash-value)) 401 | ((protocol-list-p type) 402 | (mapcar (lambda (hash-value-1) 403 | (convert-from-hash-table (second type) hash-value-1)) 404 | hash-value)) 405 | ((and (consp type) 406 | (eq 'or (first type))) 407 | (some (lambda (type-1) 408 | (maybe-protocol-type type-1 hash-value)) 409 | (rest type))))) 410 | 411 | (defgeneric convert-from-hash-table (name hash-table) 412 | (:method (name hash-table) 413 | (make-instance name) 414 | (let ((object (make-instance name))) 415 | (loop :for slot :in (c2mop:class-slots (find-class name)) 416 | :for slot-name := (c2mop:slot-definition-name slot) 417 | :for slot-type := (c2mop:slot-definition-type slot) 418 | :for hash-key := (string slot-name) 419 | :do (setf (slot-value object slot-name) 420 | (let ((hash-value (gethash hash-key hash-table))) 421 | (or (maybe-protocol-type slot-type hash-value) 422 | hash-value)))) 423 | object))) 424 | 425 | (defgeneric convert-to-hash-table (instance) 426 | (:method (instance) 427 | (let ((hash-table (make-hash-table :test 'equal))) 428 | (loop :for slot :in (c2mop:class-slots (find-class (type-of instance))) 429 | :for name := (c2mop:slot-definition-name slot) 430 | :for type := (c2mop:slot-definition-type slot) 431 | :for value := (slot-value instance name) 432 | :do 433 | (unless (eq value null-slot-value) 434 | (setf (gethash (string name) hash-table) 435 | (cond 436 | ((protocol-symbol-p type) 437 | (convert-to-hash-table value)) 438 | ((and (protocol-list-p type) (listp value)) 439 | (mapcar #'convert-to-hash-table value)) 440 | ((and (consp type) 441 | (eq 'or (car type)) 442 | (typep value 'protocol)) 443 | (convert-to-hash-table value)) 444 | (t 445 | value))))) 446 | hash-table))) 447 | 448 | (defmethod convert-to-hash-table ((instance |WorkspaceEdit|)) 449 | (let ((hash-table (make-hash-table :test 'equal))) 450 | (unless (eq null-slot-value (slot-value instance '|changes|)) 451 | (let ((changes (slot-value instance '|changes|)) 452 | (new-changes (make-hash-table :test 'equal))) 453 | (maphash (lambda (uri edits) 454 | (setf (gethash uri new-changes) 455 | (mapcar #'convert-to-hash-table edits))) 456 | changes) 457 | (setf (gethash "changes" hash-table) new-changes))) 458 | (unless (eq null-slot-value (slot-value instance '|documentChanges|)) 459 | (let ((doucment-changes (slot-value instance '|documentChanges|))) 460 | (setf (gethash "documentChanges" hash-table) 461 | (mapcar #'convert-to-hash-table doucment-changes)))) 462 | hash-table)) 463 | -------------------------------------------------------------------------------- /lem-base/basic.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-lsp.lem-base) 2 | 3 | (annot:enable-annot-syntax) 4 | 5 | @export 6 | (defun first-line-p (point) 7 | @lang(:jp "`point`が最初の行ならT、それ以外ならNILを返します。") 8 | (null (line-prev (point-line point)))) 9 | 10 | @export 11 | (defun last-line-p (point) 12 | @lang(:jp "`point`が最後の行ならT、それ以外ならNILを返します。") 13 | (null (line-next (point-line point)))) 14 | 15 | @export 16 | (defun start-line-p (point) 17 | @lang(:jp "`point`が行頭ならT、それ以外ならNILを返します。") 18 | (zerop (point-charpos point))) 19 | 20 | @export 21 | (defun end-line-p (point) 22 | @lang(:jp "`point`が行末ならT、それ以外ならNILを返します。") 23 | (= (point-charpos point) 24 | (line-length (point-line point)))) 25 | 26 | @export 27 | (defun start-buffer-p (point) 28 | @lang(:jp "`point`がバッファの最初の位置ならT、それ以外ならNILを返します。") 29 | (and (first-line-p point) 30 | (start-line-p point))) 31 | 32 | @export 33 | (defun end-buffer-p (point) 34 | @lang(:jp "`point`がバッファの最後の位置ならT、それ以外ならNILを返します。") 35 | (and (last-line-p point) 36 | (end-line-p point))) 37 | 38 | @export 39 | (defun same-line-p (point1 point2) 40 | @lang(:jp "`point1`と`point2`が同じ位置ならT、それ以外ならNILを返します。") 41 | (assert (eq (point-buffer point1) 42 | (point-buffer point2))) 43 | (eq (point-line point1) (point-line point2))) 44 | 45 | (defun %move-to-position (point linum line charpos) 46 | (assert (line-alive-p line)) 47 | (assert (<= 0 charpos)) 48 | (without-interrupts 49 | (point-change-line point linum line) 50 | (setf (point-charpos point) (min (line-length line) charpos))) 51 | point) 52 | 53 | @export 54 | (defun move-point (point new-point) 55 | @lang(:jp "`point`を`new-point`の位置に移動します。") 56 | (%move-to-position point 57 | (point-linum new-point) 58 | (point-line new-point) 59 | (point-charpos new-point))) 60 | 61 | @export 62 | (defun line-start (point) 63 | @lang(:jp "`point`を行頭に移動します。") 64 | (setf (point-charpos point) 0) 65 | point) 66 | 67 | @export 68 | (defun line-end (point) 69 | @lang(:jp "`point`を行末に移動します。") 70 | (setf (point-charpos point) 71 | (line-length (point-line point))) 72 | point) 73 | 74 | @export 75 | (defun buffer-start (point) 76 | @lang(:jp "`point`をバッファの最初の位置に移動します。") 77 | (move-point point (buffer-start-point (point-buffer point)))) 78 | 79 | @export 80 | (defun buffer-end (point) 81 | @lang(:jp "`point`をバッファの最後の位置に移動します。") 82 | (move-point point (buffer-end-point (point-buffer point)))) 83 | 84 | @export 85 | (defun line-offset (point n &optional (charpos 0)) 86 | @lang(:jp "`point`を`n`が正の数なら下に、負の数なら上に行を移動し、移動後の`point`を返します。 87 | `n`行先に行が無ければ`point`の位置はそのままでNILを返します。 88 | `charpos`は移動後の行頭からのオフセットです。 89 | ") 90 | (cond 91 | ((plusp n) 92 | (do ((i n (1- i)) 93 | (line (point-line point) (line-next line))) 94 | ((null line) nil) 95 | (when (zerop i) 96 | (%move-to-position point (+ (point-linum point) n) 97 | line charpos) 98 | (return point)))) 99 | ((minusp n) 100 | (do ((i n (1+ i)) 101 | (line (point-line point) (line-prev line))) 102 | ((null line) nil) 103 | (when (zerop i) 104 | (%move-to-position point (+ (point-linum point) n) 105 | line charpos) 106 | (return point)))) 107 | (t 108 | (setf (point-charpos point) 109 | (if (< charpos 0) 110 | 0 111 | (min charpos 112 | (line-length (point-line point))))) 113 | point))) 114 | 115 | (declaim (inline %character-offset)) 116 | (defun %character-offset (point n fn zero-fn) 117 | (cond ((zerop n) (when zero-fn (funcall zero-fn))) 118 | ((plusp n) 119 | (do ((line (point-line point) (line-next line)) 120 | (linum (point-linum point) (1+ linum)) 121 | (charpos (point-charpos point) 0)) 122 | ((null line) nil) 123 | (let ((w (- (line-length line) charpos))) 124 | (when (<= n w) 125 | (return (funcall fn linum line (+ charpos n)))) 126 | (decf n (1+ w))))) 127 | (t 128 | (setf n (- n)) 129 | (do* ((line (point-line point) (line-prev line)) 130 | (linum (point-linum point) (1- linum)) 131 | (charpos (point-charpos point) (and line (line-length line)))) 132 | ((null line) nil) 133 | (when (<= n charpos) 134 | (return (funcall fn linum line (- charpos n)))) 135 | (decf n (1+ charpos)))))) 136 | 137 | @export 138 | (defun character-offset (point n) 139 | @lang(:jp "`point`を`n`が正の数なら後に、負の数なら前に移動し、移動後の`point`を返します。 140 | `n`文字先がバッファの範囲外なら`point`の位置はそのままでNILを返します。") 141 | (%character-offset point n 142 | (lambda (linum line charpos) 143 | (%move-to-position point linum line charpos) 144 | point) 145 | (lambda () 146 | point))) 147 | 148 | @export 149 | (defun character-at (point &optional (offset 0)) 150 | @lang(:jp "`point`から`offset`ずらした位置の文字を返します。 151 | バッファの範囲外ならNILを返します。") 152 | (%character-offset point offset 153 | (lambda (linum line charpos) 154 | (declare (ignore linum)) 155 | (line-char line charpos)) 156 | (lambda () 157 | (line-char (point-line point) 158 | (point-charpos point))))) 159 | 160 | @export 161 | (defun line-string (point) 162 | @lang(:jp "`point`の行の文字列を返します。") 163 | (line-str (point-line point))) 164 | 165 | @export 166 | (defun text-property-at (point prop &optional (offset 0)) 167 | @lang(:jp "`point`から`offset`ずらした位置の`prop`のプロパティを返します。") 168 | (%character-offset point offset 169 | (lambda (linum line charpos) 170 | (declare (ignore linum)) 171 | (line-search-property line prop charpos)) 172 | (lambda () 173 | (line-search-property (point-line point) 174 | prop 175 | (point-charpos point))))) 176 | 177 | @export 178 | (defun put-text-property (start-point end-point prop value) 179 | @lang(:jp "`start-point`から`end-point`の間のテキストプロパティ`prop`を`value`にします。") 180 | (assert (eq (point-buffer start-point) 181 | (point-buffer end-point))) 182 | (%map-region start-point end-point 183 | (lambda (line start end) 184 | (line-add-property line 185 | start 186 | (if (null end) 187 | (line-length line) 188 | end) 189 | prop 190 | value 191 | (null end))))) 192 | 193 | @export 194 | (defun remove-text-property (start-point end-point prop) 195 | @lang(:jp "`start-point`から`end-point`までのテキストプロパティ`prop`を削除します。") 196 | (assert (eq (point-buffer start-point) 197 | (point-buffer end-point))) 198 | (%map-region start-point end-point 199 | (lambda (line start end) 200 | (line-remove-property line 201 | start 202 | (if (null end) 203 | (line-length line) 204 | end) 205 | prop)))) 206 | 207 | ;; 下の二つの関数next-single-property-change, previous-single-property-changeは 208 | ;; 効率がとても悪いので時が来たら書き直す 209 | 210 | 211 | @export 212 | (defun next-single-property-change (point prop &optional limit-point) 213 | @lang(:jp "`point`からテキストプロパティ`prop`の値が異なる位置まで後の方向に移動し、 214 | 移動後の`point`を返します。 215 | バッファの最後まで走査が止まらないか、`limit-point`を越えると走査を中断しNILを返します。") 216 | (let ((first-value (text-property-at point prop))) 217 | (with-point ((curr point)) 218 | (loop 219 | (unless (character-offset curr 1) 220 | (return nil)) 221 | (unless (eq first-value (text-property-at curr prop)) 222 | (return (move-point point curr))) 223 | (when (and limit-point (point<= limit-point curr)) 224 | (return nil)))))) 225 | 226 | @export 227 | (defun previous-single-property-change (point prop &optional limit-point) 228 | @lang(:jp "`point`からテキストプロパティ`prop`の値が異なる位置まで前の方向に移動し、 229 | 移動後の`point`を返します。 230 | バッファの最初の位置まで走査が止まらないか、`limit-point`を越えると走査を中断しNILを返します。") 231 | (let ((first-value (text-property-at point prop -1))) 232 | (with-point ((curr point)) 233 | (loop 234 | (unless (eq first-value (text-property-at curr prop -1)) 235 | (return (move-point point curr))) 236 | (unless (character-offset curr -1) 237 | (return nil)) 238 | (when (and limit-point (point>= limit-point curr)) 239 | (return nil)))))) 240 | 241 | @export 242 | (defun insert-character (point char &optional (n 1)) 243 | @lang(:jp "`point`に文字`char`を`n`回挿入します。") 244 | (loop :repeat n :do (insert-char/point point char)) 245 | t) 246 | 247 | @export 248 | (defun insert-string (point string &rest plist) 249 | @lang(:jp "`point`に文字列`string`を挿入します。 250 | `plist`を指定すると`string`を挿入した範囲にテキストプロパティを設定します。") 251 | (if (null plist) 252 | (insert-string/point point string) 253 | (with-point ((start-point point)) 254 | (insert-string/point point string) 255 | (let ((end-point (character-offset (copy-point start-point :temporary) 256 | (length string)))) 257 | (loop :for (k v) :on plist :by #'cddr 258 | :do (put-text-property start-point end-point k v))))) 259 | t) 260 | 261 | @export 262 | (defun delete-character (point &optional (n 1)) 263 | @lang(:jp "`point`から`n`個文字を削除し、削除した文字列を返します。 264 | `n`個の文字を削除する前にバッファの末尾に達した場合はNILを返します。") 265 | (when (minusp n) 266 | (unless (character-offset point n) 267 | (return-from delete-character nil)) 268 | (setf n (- n))) 269 | (unless (end-buffer-p point) 270 | (let ((string (delete-char/point point n))) 271 | string))) 272 | 273 | @export 274 | (defun erase-buffer (&optional (buffer (current-buffer))) 275 | @lang(:jp "`buffer`のテキストをすべて削除します。") 276 | (buffer-start (buffer-point buffer)) 277 | (delete-char/point (buffer-point buffer) 278 | (count-characters (buffer-start-point buffer) 279 | (buffer-end-point buffer)))) 280 | 281 | @export 282 | (defun region-beginning (&optional (buffer (current-buffer))) 283 | @lang(:jp "`buffer`内のリージョンの始まりの位置の`point`を返します。") 284 | (let ((start (buffer-point buffer)) 285 | (end (buffer-mark buffer))) 286 | (if (point< start end) 287 | start 288 | end))) 289 | 290 | @export 291 | (defun region-end (&optional (buffer (current-buffer))) 292 | @lang(:jp "`buffer`内のリージョンの終わりの位置の`point`を返します。") 293 | (let ((start (buffer-point buffer)) 294 | (end (buffer-mark buffer))) 295 | (if (point< start end) 296 | end 297 | start))) 298 | 299 | (defun %map-region (start end function) 300 | (when (point< end start) 301 | (rotatef start end)) 302 | (let ((start-line (point-line start)) 303 | (end-line (point-line end))) 304 | (loop :for line := start-line :then (line-next line) 305 | :for firstp := (eq line start-line) 306 | :for lastp := (eq line end-line) 307 | :do (funcall function 308 | line 309 | (if firstp 310 | (point-charpos start) 311 | 0) 312 | (if lastp 313 | (point-charpos end) 314 | nil)) 315 | :until lastp)) 316 | (values)) 317 | 318 | @export 319 | (defun map-region (start end function) 320 | (%map-region start end 321 | (lambda (line start end) 322 | (funcall function 323 | (subseq (line-str line) start end) 324 | (not (null end)))))) 325 | 326 | @export 327 | (defun points-to-string (start-point end-point) 328 | @lang(:jp "`start-point`から`end-point`までの範囲の文字列を返します。") 329 | (assert (eq (point-buffer start-point) 330 | (point-buffer end-point))) 331 | (with-output-to-string (out) 332 | (map-region start-point end-point 333 | (lambda (string lastp) 334 | (write-string string out) 335 | (unless lastp 336 | (write-char #\newline out)))))) 337 | 338 | @export 339 | (defun count-characters (start-point end-point) 340 | @lang(:jp "`start-point`から`end-point`までの文字列の長さを返します。") 341 | (let ((count 0)) 342 | (map-region start-point 343 | end-point 344 | (lambda (string lastp) 345 | (incf count (length string)) 346 | (unless lastp 347 | (incf count)))) 348 | count)) 349 | 350 | @export 351 | (defun delete-between-points (start-point end-point) 352 | @lang(:jp "`start-point`から`end-point`までの範囲を削除し、削除した文字列を返します。") 353 | (assert (eq (point-buffer start-point) 354 | (point-buffer end-point))) 355 | (unless (point< start-point end-point) 356 | (rotatef start-point end-point)) 357 | (delete-char/point start-point 358 | (count-characters start-point end-point))) 359 | 360 | @export 361 | (defun count-lines (start-point end-point) 362 | @lang(:jp "`start-point`から`end-point`までの行数を返します。") 363 | (assert (eq (point-buffer start-point) 364 | (point-buffer end-point))) 365 | (abs (- (point-linum start-point) 366 | (point-linum end-point)))) 367 | 368 | @export 369 | (defun apply-region-lines (start-point end-point function) 370 | @lang(:jp "`start-point`から`end-point`の各行に対して 371 | ポイントを引数に取る`function`を適用します。") 372 | (when (point< end-point start-point) 373 | (rotatef start-point end-point)) 374 | (with-point ((start-point start-point :right-inserting) 375 | (end-point end-point :right-inserting) 376 | (point start-point)) 377 | (loop :while (point< start-point end-point) :do 378 | (funcall function (move-point point start-point)) 379 | (unless (line-offset start-point 1) 380 | (return))))) 381 | 382 | @export 383 | (defun filter-region-lines (start-point end-point function) 384 | @lang(:jp "`start-point`から`end-point`までの範囲の行に`function`を適用します。 385 | `function`は行の文字列を引数に取り新しい行の文字列を返す関数です。") 386 | (assert (eq (point-buffer start-point) 387 | (point-buffer end-point))) 388 | (when (point< end-point start-point) 389 | (rotatef end-point start-point)) 390 | (let ((fstr (make-array '(0) :element-type 'character :fill-pointer 0 :adjustable t)) 391 | (length 0)) 392 | (with-output-to-string (out fstr) 393 | (map-region start-point end-point 394 | (lambda (string lastp) 395 | (incf length (1+ (length string))) 396 | (write-string (funcall function string) out) 397 | (unless lastp 398 | (write-char #\newline out))))) 399 | (delete-char/point start-point length) 400 | (insert-string start-point fstr))) 401 | 402 | @export 403 | (defun line-number-at-point (point) 404 | @lang(:jp "`point`の行番号を返します。") 405 | (point-linum point)) 406 | 407 | @export 408 | (defun point-column (point) 409 | @lang(:jp "`point`の行頭からの列幅を返します。") 410 | (string-width (line-string point) 411 | 0 412 | (point-charpos point))) 413 | 414 | @export 415 | (defun move-to-column (point column &optional force) 416 | @lang(:jp "`point`を行頭から列幅`column`まで移動し、移動後の`point`を返します。 417 | `force`が非NILの場合は、行の長さが`column`より少なければ空白を挿入して移動し、 418 | `force`がNILの場合は、行末まで移動し、移動後の`point`を返します。") 419 | (line-end point) 420 | (let ((cur-column (point-column point))) 421 | (cond ((< column cur-column) 422 | (setf (point-charpos point) 423 | (wide-index (line-string point) column)) 424 | point) 425 | (force 426 | (insert-character point #\space (- column cur-column)) 427 | (line-end point)) 428 | (t 429 | (line-end point))))) 430 | 431 | @export 432 | (defun position-at-point (point) 433 | @lang(:jp "`point`のバッファの先頭からの1始まりのオフセットを返します。") 434 | (let ((offset (point-charpos point))) 435 | (do ((line (line-prev (point-line point)) (line-prev line))) 436 | ((null line) (1+ offset)) 437 | (incf offset (1+ (line-length line)))))) 438 | 439 | @export 440 | (defun move-to-position (point position) 441 | @lang(:jp "`point`をバッファの先頭からの1始まりのオフセット`position`に移動してその位置を返します。 442 | `position`がバッファの範囲外なら`point`は移動せず、NILを返します。") 443 | (character-offset (buffer-start point) (1- position))) 444 | 445 | @export 446 | (defun move-to-line (point line-number) 447 | @lang(:jp "`point`を行番号`line-number`に移動し、移動後の位置を返します。 448 | `line-number`がバッファの範囲外なら`point`は移動せず、NILを返します。") 449 | (let ((cur-linum (line-number-at-point point)) 450 | (nlines (buffer-nlines (point-buffer point)))) 451 | (cond ((or (> 1 line-number) 452 | (< nlines line-number)) 453 | nil) 454 | ((= line-number cur-linum) 455 | point) 456 | ((< line-number cur-linum) 457 | (if (< line-number (- cur-linum line-number)) 458 | (line-offset (buffer-start point) (1- line-number)) 459 | (line-offset point (- line-number cur-linum)))) 460 | (t 461 | (if (< (- line-number cur-linum) (- nlines line-number)) 462 | (line-offset point (- line-number cur-linum)) 463 | (line-offset (buffer-end point) (- line-number nlines))))))) 464 | 465 | @export 466 | (defun check-marked () 467 | (unless (buffer-mark (current-buffer)) 468 | (editor-error "Not mark in this buffer"))) 469 | 470 | @export 471 | (defun set-current-mark (point) 472 | @lang(:jp "`point`を現在のマークに設定します。") 473 | (let ((buffer (point-buffer point))) 474 | (setf (buffer-mark-p buffer) t) 475 | (cond ((buffer-mark buffer) 476 | (move-point (buffer-mark buffer) point)) 477 | (t 478 | (setf (buffer-mark buffer) 479 | (copy-point point :right-inserting))))) 480 | point) 481 | 482 | @export 483 | (defun blank-line-p (point) 484 | (let ((string (line-string point)) 485 | (eof-p (last-line-p point)) 486 | (count 0)) 487 | (loop :for c :across string :do 488 | (unless (or (char= c #\space) 489 | (char= c #\tab)) 490 | (return-from blank-line-p nil)) 491 | (incf count)) 492 | (if eof-p 493 | count 494 | (1+ count)))) 495 | 496 | (defun skip-chars-internal (point test dir) 497 | (loop :for count :from 0 498 | :for c := (character-at point (if dir 0 -1)) 499 | :do 500 | (unless (if (consp test) 501 | (member c test) 502 | (funcall test c)) 503 | (return count)) 504 | (unless (character-offset point (if dir 1 -1)) 505 | (return count)))) 506 | 507 | @export 508 | (defun skip-chars-forward (point test) 509 | @lang(:jp "`point`からその位置の文字を`test`で評価して非NILの間、後の方向に移動します。 510 | `test`が文字のリストならその位置の文字が`test`のリスト内に含まれるか 511 | `test`が関数ならその位置の文字を引数として一つ取り、返り値が非NILであるか 512 | ") 513 | (skip-chars-internal point test t)) 514 | 515 | @export 516 | (defun skip-chars-backward (point test) 517 | @lang(:jp "`point`からその位置の前の文字を`test`で評価して非NILの間、前の方向に移動します。 518 | `test`が文字のリストならその位置の前の文字が`test`のリスト内に含まれるか 519 | `test`が関数ならその位置の前の文字を引数として一つ取り、返り値が非NILであるか 520 | ") 521 | (skip-chars-internal point test nil)) 522 | 523 | (defun invoke-save-excursion (function) 524 | (let ((point (copy-point (current-point) :right-inserting)) 525 | (mark (when (buffer-mark-p (current-buffer)) 526 | (copy-point (buffer-mark (current-buffer)) 527 | :right-inserting)))) 528 | (unwind-protect (funcall function) 529 | (setf (current-buffer) (point-buffer point)) 530 | (move-point (current-point) point) 531 | (delete-point point) 532 | (when mark 533 | (set-current-mark mark) 534 | (delete-point mark))))) 535 | -------------------------------------------------------------------------------- /server.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-lsp/server 2 | (:use :cl 3 | :cl-lsp/protocol 4 | :cl-lsp/protocol-util 5 | :cl-lsp/logger 6 | :cl-lsp/slime 7 | :cl-lsp/swank 8 | :cl-lsp/formatting 9 | :cl-lsp.lem-base) 10 | (:import-from :cl-lsp.lem-lisp-syntax.syntax-table 11 | :*syntax-table*) 12 | (:import-from :cl-lsp.lem-lisp-syntax.enclosing 13 | :search-local-definition) 14 | (:export :*server* 15 | :*method-lock* 16 | :*initialized-hooks* 17 | :with-error-handle 18 | :define-method 19 | :get-buffer-from-uri 20 | :with-document-position 21 | :with-text-document-position 22 | :notify-show-message 23 | :notify-log-message)) 24 | (in-package :cl-lsp/server) 25 | 26 | (defvar *server* (jsonrpc:make-server)) 27 | (defvar *method-lock* (bt:make-lock)) 28 | (defvar *initialized-hooks* '()) 29 | 30 | (defvar *request-log* t) 31 | (defvar *response-log* t) 32 | 33 | (defun request-log (name params) 34 | (when *request-log* 35 | (log-format "~%* from client~%") 36 | (log-format "name: ~A~%" name) 37 | (log-format "params: ~A~%" 38 | (with-output-to-string (stream) 39 | (yason:encode params stream))))) 40 | 41 | (defun response-log (hash) 42 | (when *response-log* 43 | (log-format "~%* to server~%~A~%" 44 | (with-output-to-string (out) 45 | (yason:encode hash out))))) 46 | 47 | (defun call-with-error-handle (function) 48 | (catch 'call-with-error-handle 49 | (handler-bind ((error (lambda (c) 50 | (log-format "~A~%~%~A~%" 51 | c 52 | (with-output-to-string (stream) 53 | (uiop:print-backtrace :stream stream 54 | :condition c))) 55 | (throw 'call-with-error-handle nil)))) 56 | (funcall function)))) 57 | 58 | (defmacro with-error-handle (&body body) 59 | `(call-with-error-handle (lambda () ,@body))) 60 | 61 | (defmacro define-method (name (params &optional params-type without-lock) &body body) 62 | (let ((_val (gensym))) 63 | `(jsonrpc:expose *server* 64 | ,name 65 | (lambda (,params) 66 | (with-error-handle 67 | (request-log ',name ,params) 68 | (let ((,_val 69 | (let ((,params ,(if params-type 70 | `(convert-from-hash-table ',params-type ,params) 71 | params))) 72 | (declare (ignorable ,params)) 73 | (check-initialized ,name) 74 | ,(if without-lock 75 | `(progn ,@body) 76 | `(bt:with-lock-held (*method-lock*) ,@body))))) 77 | (response-log ,_val) 78 | ,_val)))))) 79 | 80 | (defun get-buffer-from-uri (uri) 81 | (get-buffer uri)) 82 | 83 | (defun call-with-document-position (uri position function) 84 | (let ((buffer (get-buffer-from-uri uri))) 85 | (assert (bufferp buffer)) 86 | (let ((point (buffer-point buffer))) 87 | (move-to-lsp-position point position) 88 | (funcall function point)))) 89 | 90 | (defmacro with-document-position ((point uri position) &body body) 91 | `(call-with-document-position ,uri ,position (lambda (,point) ,@body))) 92 | 93 | (defun call-with-text-document-position (text-document-position-params function) 94 | (let ((position (slot-value text-document-position-params '|position|)) 95 | (uri (slot-value (slot-value text-document-position-params '|textDocument|) '|uri|))) 96 | (call-with-document-position uri position function))) 97 | 98 | (defmacro with-text-document-position ((point) params &body body) 99 | `(call-with-text-document-position ,params (lambda (,point) ,@body))) 100 | 101 | (defun notify-show-message (type message) 102 | (log-format "window/showMessage: ~A ~A~%" type message) 103 | (jsonrpc:notify-async *server* 104 | "window/showMessage" 105 | (convert-to-hash-table 106 | (make-instance '|ShowMessageParams| 107 | :|type| type 108 | :|message| message)))) 109 | 110 | (defun notify-log-message (type message) 111 | (log-format "window/logMessage: ~A ~A~%" type message) 112 | (jsonrpc:notify-async *server* 113 | "window/logMessage" 114 | (convert-to-hash-table 115 | (make-instance '|LogMessageParams| 116 | :|type| type 117 | :|message| message)))) 118 | 119 | (defvar *initialize-params* nil) 120 | 121 | (defun check-initialized (method-name) 122 | (when (and (string/= method-name "initialize") 123 | (null *initialize-params*)) 124 | (alexandria:plist-hash-table 125 | (list "code" -32002 126 | "message" "did not initialize") 127 | :test 'equal))) 128 | 129 | (define-method "initialize" (params |InitializeParams|) 130 | (setf *initialize-params* params) 131 | (convert-to-hash-table 132 | (make-instance 133 | '|InitializeResult| 134 | :|capabilities| 135 | (make-instance 136 | '|ServerCapabilities| 137 | :|textDocumentSync| (progn 138 | #+(or) 139 | (make-instance 140 | '|TextDocumentSyncOptions| 141 | :|openClose| t 142 | :|change| |TextDocumentSyncKind.Incremental| 143 | :|willSave| 'yason:false 144 | :|willSaveWaitUntil| 'yason:false 145 | :|save| (make-instance '|SaveOptions| :|includeText| t)) 146 | |TextDocumentSyncKind.Incremental|) 147 | :|hoverProvider| t 148 | :|completionProvider| (make-instance 149 | '|CompletionOptions| 150 | :|resolveProvider| nil 151 | :|triggerCharacters| (loop :for code 152 | :from (char-code #\a) 153 | :below (char-code #\z) 154 | :collect (string (code-char code)))) 155 | :|signatureHelpProvider| (make-instance 156 | '|SignatureHelpOptions| 157 | :|triggerCharacters| (list " ")) 158 | :|definitionProvider| t 159 | :|referencesProvider| t 160 | :|documentHighlightProvider| t 161 | :|documentSymbolProvider| t 162 | :|workspaceSymbolProvider| t 163 | :|codeActionProvider| nil 164 | :|codeLensProvider| nil 165 | :|documentFormattingProvider| t 166 | :|documentRangeFormattingProvider| t 167 | :|documentOnTypeFormattingProvider| (make-instance 168 | '|DocumentOnTypeFormattingOptions| 169 | :|firstTriggerCharacter| (string #\Newline)) 170 | :|renameProvider| t 171 | :|documentLinkProvider| nil 172 | :|executeCommandProvider| nil 173 | :|experimental| nil)))) 174 | 175 | (define-method "initialized" (params) 176 | (swank-init) 177 | (mapc #'funcall *initialized-hooks*) 178 | nil) 179 | 180 | (define-method "shutdown" (params) 181 | t) 182 | 183 | (define-method "exit" (params) 184 | (values)) 185 | 186 | (define-method "workspace/didChangeConfiguration" (params) 187 | nil) 188 | 189 | (define-method "workspace/symbol" (params |WorkspaceSymbolParams|) 190 | (let* ((query (slot-value params '|query|)) 191 | (limit 42)) 192 | (list-to-object[] 193 | (when (string/= query "") 194 | (mapcar #'convert-to-hash-table 195 | (loop :with package := (find-package "CL-USER") 196 | :repeat limit 197 | :for name :in (swank-apropos-list query package) 198 | :append (symbol-informations name package nil))))))) 199 | 200 | (define-method "textDocument/didOpen" (params |DidOpenTextDocumentParams|) 201 | (let ((text-document 202 | (slot-value params 203 | '|textDocument|))) 204 | (with-slots (|uri| |languageId| |version| |text|) 205 | text-document 206 | (let ((buffer (make-buffer |uri| 207 | :filename (uri-to-filename |uri|) 208 | :enable-undo-p nil 209 | :syntax-table *syntax-table*))) 210 | (insert-string (buffer-point buffer) |text|) 211 | (setf (buffer-value buffer 'document) 212 | (list :languageId |languageId| 213 | :version |version|))))) 214 | (values)) 215 | 216 | (define-method "textDocument/didChange" (params |DidChangeTextDocumentParams|) 217 | (let ((text-document (slot-value params '|textDocument|)) 218 | (content-changes (slot-value params '|contentChanges|))) 219 | (let* ((buffer (get-buffer (slot-value text-document '|uri|))) 220 | (point (buffer-point buffer))) 221 | (dolist (content-change content-changes) 222 | (with-slots (|range| |rangeLength| |text|) 223 | content-change 224 | (cond ((or (null |range|) (null |rangeLength|)) 225 | (erase-buffer buffer) 226 | (insert-string point |text|)) 227 | (t 228 | (with-slots (|start|) |range| 229 | (move-to-lsp-position point |start|) 230 | (delete-character point |rangeLength|) 231 | (insert-string point |text|))))))))) 232 | 233 | (define-method "textDocument/willSave" (params) 234 | ) 235 | 236 | (define-method "textDocument/willSaveWaitUntil" (params) 237 | ) 238 | 239 | (define-method "textDocument/didSave" (params |DidSaveTextDocumentParams|) 240 | (let* ((text 241 | (slot-value params '|text|)) 242 | (text-document 243 | (slot-value params '|textDocument|)) 244 | (uri 245 | (slot-value text-document '|uri|)) 246 | (buffer 247 | (get-buffer uri))) 248 | (when text 249 | (erase-buffer buffer) 250 | (insert-string (buffer-point buffer) text))) 251 | (values)) 252 | 253 | (define-method "textDocument/didClose" (params |DidCloseTextDocumentParams|) 254 | (let* ((text-document 255 | (slot-value params '|textDocument|)) 256 | (uri 257 | (slot-value text-document '|uri|)) 258 | (buffer 259 | (get-buffer uri))) 260 | (delete-buffer buffer)) 261 | (values)) 262 | 263 | (define-method "textDocument/completion" (params |TextDocumentPositionParams|) 264 | (with-text-document-position (point) params 265 | (with-point ((start point) 266 | (end point)) 267 | (skip-symbol-backward start) 268 | (skip-symbol-forward end) 269 | (let ((result 270 | (fuzzy-completions 271 | (points-to-string start end) 272 | (search-buffer-package point)))) 273 | (when result 274 | (destructuring-bind (completions timeout) result 275 | (declare (ignore timeout)) 276 | (convert-to-hash-table 277 | (make-instance 278 | '|CompletionList| 279 | :|isIncomplete| nil 280 | :|items| (loop :for completion :in completions 281 | :collect (make-instance 282 | '|CompletionItem| 283 | :|label| (first completion) 284 | ;:|kind| 285 | :|detail| (fourth completion) 286 | ;:|documentation| 287 | ;:|sortText| 288 | ;:|filterText| 289 | ;:|insertText| 290 | ;:|insertTextFormat| 291 | :|textEdit| (make-instance 292 | '|TextEdit| 293 | :|range| (make-lsp-range start end) 294 | :|newText| (first completion)) 295 | ;:|additionalTextEdits| 296 | ;:|command| 297 | ;:|data| 298 | )))))))))) 299 | 300 | (define-method "textDocument/hover" (params |TextDocumentPositionParams|) 301 | (with-text-document-position (point) params 302 | (let* ((symbol-string (symbol-string-at-point* point)) 303 | (describe-string 304 | (describe-symbol symbol-string 305 | (search-buffer-package point)))) 306 | (convert-to-hash-table 307 | (if describe-string 308 | (with-point ((start point) 309 | (end point)) 310 | (skip-chars-backward start #'syntax-symbol-char-p) 311 | (skip-chars-forward end #'syntax-symbol-char-p) 312 | (make-instance '|Hover| 313 | :|contents| describe-string 314 | :|range| (make-lsp-range start end))) 315 | (make-instance '|Hover| 316 | :|contents| "")))))) 317 | 318 | (defun arglist (point) 319 | (loop :with start := (beginning-of-defun-point point 1) 320 | :while (form-offset point -1) 321 | :do (when (point< point start) 322 | (return-from arglist nil))) 323 | (skip-whitespace-forward point) 324 | (let ((symbol-string (symbol-string-at-point* point))) 325 | (when symbol-string 326 | (operator-arglist symbol-string 327 | (search-buffer-package point))))) 328 | 329 | (define-method "textDocument/signatureHelp" (params |TextDocumentPositionParams|) 330 | (with-text-document-position (point) params 331 | (let ((arglist (arglist point))) 332 | (convert-to-hash-table 333 | (make-instance 334 | '|SignatureHelp| 335 | :|signatures| (when arglist 336 | (list (make-instance 337 | '|SignatureInformation| 338 | :|label| arglist)))))))) 339 | 340 | (defun xref-location (xref) 341 | (optima:match xref 342 | ((list _ 343 | (list :location 344 | (list :file file) 345 | (list :position offset) 346 | (list :snippet _))) 347 | (convert-to-hash-table (file-location file offset))))) 348 | 349 | (defun xref-locations-from-definitions (defs) 350 | (loop :for xref :in defs 351 | :for location := (xref-location xref) 352 | :when location 353 | :collect location)) 354 | 355 | (define-method "textDocument/definition" (params |TextDocumentPositionParams|) 356 | (with-text-document-position (point) params 357 | (alexandria:when-let ((name (symbol-string-at-point* point))) 358 | (alexandria:if-let ((p (search-local-definition point name))) 359 | (convert-to-hash-table (buffer-location p)) 360 | (list-to-object-or-object[] 361 | (xref-locations-from-definitions 362 | (find-definitions name (search-buffer-package point)))))))) 363 | 364 | (define-method "textDocument/references" (params |ReferenceParams|) 365 | (with-text-document-position (point) params 366 | (let ((symbol-string (symbol-string-at-point* point))) 367 | (list-to-object-or-object[] 368 | (loop :for (type . definitions) :in (xrefs symbol-string 369 | (search-buffer-package point)) 370 | :nconc (xref-locations-from-definitions definitions)))))) 371 | 372 | (defun collect-symbol-range (buffer name function) 373 | (let ((regex (ppcre:create-scanner `(:sequence 374 | (:alternation 375 | (:positive-lookbehind 376 | (:char-class #\( #\) #\space #\tab #\:)) 377 | :start-anchor) 378 | ,name 379 | (:alternation 380 | (:positive-lookahead 381 | (:char-class #\( #\) #\space #\tab #\:)) 382 | :end-anchor)) 383 | :case-insensitive-mode t))) 384 | (with-point ((point (buffer-start-point buffer))) 385 | (loop :while (search-forward-regexp point regex) 386 | :collect (with-point ((start point)) 387 | (character-offset start (- (length name))) 388 | (funcall function (make-lsp-range start point))))))) 389 | 390 | (defun symbol-name-at-point (point) 391 | (alexandria:when-let* 392 | ((string (symbol-string-at-point* point)) 393 | (name (ignore-errors 394 | (symbol-name 395 | (let ((*package* (search-buffer-package point))) 396 | (read-from-string string)))))) 397 | name)) 398 | 399 | (define-method "textDocument/documentHighlight" (params |TextDocumentPositionParams|) 400 | (with-text-document-position (point) params 401 | (list-to-object[] 402 | (alexandria:when-let (name (symbol-name-at-point point)) 403 | (collect-symbol-range (point-buffer point) name 404 | (lambda (range) 405 | (convert-to-hash-table 406 | (make-instance '|DocumentHighlight| 407 | :|range| range)))))))) 408 | 409 | (defun type-to-symbol-kind (type) 410 | #+sbcl 411 | (case type 412 | (defvar |SymbolKind.Variable|) 413 | (defconstant |SymbolKind.Variable|) 414 | (deftype |SymbolKind.Class|) 415 | (define-symbol-macro |SymbolKind.Variable|) 416 | (defmacro |SymbolKind.Function|) 417 | (define-compiler-macro |SymbolKind.Function|) 418 | (defun |SymbolKind.Function|) 419 | (defgeneric |SymbolKind.Method|) 420 | (defmethod |SymbolKind.Method|) 421 | (define-setf-expander |SymbolKind.Function|) 422 | (defstruct |SymbolKind.Class|) 423 | (define-condition |SymbolKind.Class|) 424 | (defclass |SymbolKind.Class|) 425 | (define-method-combination |SymbolKind.Function|) 426 | (defpackage |SymbolKind.Namespace|) 427 | (:deftransform |SymbolKind.Function|) 428 | (:defoptimizer |SymbolKind.Function|) 429 | (:define-vop |SymbolKind.Function|) 430 | (:define-source-transform |SymbolKind.Function|) 431 | (:def-ir1-translator |SymbolKind.Function|) 432 | (declaim |SymbolKind.Function|) 433 | (:define-alien-type |SymbolKind.Function|) 434 | (otherwise 435 | |SymbolKind.Function|)) 436 | #-sbcl 437 | |SymbolKind.Function|) 438 | 439 | (defun xref-to-symbol-information (name xref buffer-file) 440 | (optima:match xref 441 | ((list (cons type _) 442 | (list :location 443 | (list :file file) 444 | (list :position position) 445 | (list :snippet _))) 446 | (when (and (probe-file file) 447 | (or (null buffer-file) 448 | (equal file buffer-file))) 449 | (make-instance '|SymbolInformation| 450 | :|name| name 451 | :|kind| (type-to-symbol-kind type) 452 | :|location| (file-location file position)))))) 453 | 454 | (defun symbol-informations (name package buffer-file) 455 | (loop :for xref :in (find-definitions name package) 456 | :for info := (xref-to-symbol-information name xref buffer-file) 457 | :when info 458 | :collect info)) 459 | 460 | (defun document-symbol (buffer) 461 | (let ((symbol-informations '()) 462 | (used (make-hash-table :test 'equal)) 463 | (package (search-buffer-package (buffer-start-point buffer))) 464 | (buffer-file (buffer-filename buffer))) 465 | (map-buffer-symbols 466 | buffer 467 | (lambda (symbol-string) 468 | (unless (gethash symbol-string used) 469 | (setf (gethash symbol-string used) t) 470 | (dolist (si (symbol-informations symbol-string package buffer-file)) 471 | (push si symbol-informations))))) 472 | (if (null symbol-informations) 473 | (vector) 474 | (mapcar #'convert-to-hash-table 475 | symbol-informations)))) 476 | 477 | (define-method "textDocument/documentSymbol" (params |DocumentSymbolParams|) 478 | (let* ((text-document (slot-value params '|textDocument|)) 479 | (uri (slot-value text-document '|uri|)) 480 | (buffer (get-buffer uri))) 481 | (when buffer 482 | (document-symbol buffer)))) 483 | 484 | (define-method "textDocument/formatting" (params |DocumentFormattingParams|) 485 | (with-slots (|textDocument| |options|) params 486 | (let ((buffer (get-buffer-from-uri (slot-value |textDocument| '|uri|)))) 487 | (buffer-formatting buffer |options|)))) 488 | 489 | (define-method "textDocument/rangeFormatting" (params |DocumentRangeFormattingParams|) 490 | (with-slots (|textDocument| |range| |options|) params 491 | (with-slots (|start| |end|) |range| 492 | (with-document-position (start (slot-value |textDocument| '|uri|) |start|) 493 | (with-point ((end start)) 494 | (move-to-lsp-position end |end|) 495 | (range-formatting start end |options|)))))) 496 | 497 | (define-method "textDocument/onTypeFormatting" (params |DocumentOnTypeFormattingParams|) 498 | (with-slots (|textDocument| |position| |ch| |options|) params 499 | (with-document-position (point (slot-value |textDocument| '|uri|) |position|) 500 | (on-type-formatting point |ch| |options|)))) 501 | 502 | (define-method "textDocument/codeLens" (params) 503 | (vector)) 504 | 505 | (define-method "textDocument/documentLink" (params) 506 | (vector)) 507 | 508 | (define-method "textDocument/rename" (params |RenameParams|) 509 | (with-slots (|textDocument| |position| |newName|) params 510 | (with-document-position (point (slot-value |textDocument| '|uri|) |position|) 511 | (alexandria:when-let ((name (symbol-name-at-point point))) 512 | (let* ((buffer (point-buffer point)) 513 | (uri (filename-to-uri (buffer-filename buffer))) 514 | (edits (collect-symbol-range 515 | (point-buffer point) 516 | name 517 | (lambda (range) 518 | (make-instance '|TextEdit| 519 | :|range| range 520 | :|newText| |newName|))))) 521 | (convert-to-hash-table 522 | (make-instance 523 | '|WorkspaceEdit| 524 | :|changes| (alexandria:plist-hash-table (list uri edits)) 525 | ;; :|documentChanges| (list 526 | ;; (make-instance 527 | ;; '|TextDocumentEdit| 528 | ;; :|textDocument| (make-instance 529 | ;; '|VersionedTextDocumentIdentifier| 530 | ;; :|version| (buffer-version buffer) 531 | ;; :|uri| uri) 532 | ;; :|edits| edits)) 533 | ))))))) 534 | --------------------------------------------------------------------------------