EmacsのLSPクライアントを書く

;;; my-lsp.el --- Minimal TypeScript LSP client over stdio  -*- lexical-binding: t; -*-

;; Copyright (C) 2026 TakesxiSximada

;; Author: TakesxiSximada
;; Keywords: languages, tools
;; License: GNU Affero General Public License version 3 or later

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; Minimal TypeScript LSP client for Emacs.
;; It starts `typescript-language-server` in Docker over stdio and connects
;; it to `xref` for definitions and references.

;;; Code:

(require 'cl-lib)
(require 'json)
(require 'subr-x)
(require 'url-util)
(require 'xref)

(defgroup my-ts-lsp nil
  "Minimal TypeScript LSP client over stdio."
  :group 'tools)

(defconst my-ts-lsp-docker-image
  "sximada/agentic/all:202605.dev1"
  "Docker image used to start the TypeScript language server.")

(defvar my-ts-lsp--process nil
  "Process object for the TypeScript language server.")

(defvar my-ts-lsp--stderr-buffer "*ts-lsp-stderr*"
  "Buffer name used for the TypeScript language server stderr.")

(defvar my-ts-lsp--stdout-buffer "*ts-lsp*"
  "Buffer name used for the TypeScript language server stdout.")

(defvar my-ts-lsp--response-table (make-hash-table :test #'eql)
  "Pending synchronous responses keyed by request id.")

(defvar my-ts-lsp--notification-handlers (make-hash-table :test #'equal)
  "Registered notification handlers keyed by method name.")

(defvar my-ts-lsp--next-id 0
  "Next JSON-RPC request id.")

(defvar my-ts-lsp--read-buffer ""
  "Accumulated unread stdout bytes from the language server.")

(defvar my-ts-lsp--initialized nil
  "Non-nil when initialize/initialized has completed.")

(defvar my-ts-lsp--root-dir nil
  "Project root used for the current TypeScript language server.")

(defvar my-ts-lsp--opened-files (make-hash-table :test #'equal)
  "Version table keyed by absolute file name.")

(defvar-local my-ts-lsp--managed-buffer nil
  "Non-nil when the current buffer is tracked by the TypeScript LSP.")

(defun my-ts-lsp--project-root ()
  "Return the TypeScript project root for the current buffer."
  (or (locate-dominating-file default-directory "tsconfig.json")
      (locate-dominating-file default-directory "package.json")
      (error "No TypeScript project root found from %s" default-directory)))

(defun my-ts-lsp--file-uri (path)
  "Convert PATH to a file URI."
  (url-encode-url (concat "file://" (expand-file-name path))))

(defun my-ts-lsp--uri-path (uri)
  "Convert file URI to a local path."
  (url-unhex-string (string-remove-prefix "file://" uri)))

(defun my-ts-lsp--docker-command (project-dir)
  "Build the Docker command used to start the TypeScript language server."
  (let ((root (directory-file-name (expand-file-name project-dir))))
    (list "docker" "run" "--rm" "-i"
          "--volume" (format "%s:%s" root root)
          "--workdir" root
          my-ts-lsp-docker-image
          "npx" "typescript-language-server" "--stdio")))

(defun my-ts-lsp--live-p ()
  "Return non-nil when the language server process is running."
  (process-live-p my-ts-lsp--process))

(defun my-ts-lsp--cleanup-state ()
  "Reset all transient client state."
  (setq my-ts-lsp--initialized nil
        my-ts-lsp--read-buffer ""
        my-ts-lsp--root-dir nil
        my-ts-lsp--next-id 0
        my-ts-lsp--response-table (make-hash-table :test #'eql)
        my-ts-lsp--opened-files (make-hash-table :test #'equal)))

(defun my-ts-lsp--process-filter (_proc chunk)
  "Decode LSP messages from CHUNK."
  (setq my-ts-lsp--read-buffer (concat my-ts-lsp--read-buffer chunk))
  (my-ts-lsp--drain-read-buffer))

(defun my-ts-lsp--process-sentinel (_proc event)
  "Handle server lifecycle EVENT."
  (unless (my-ts-lsp--live-p)
    (message "ts-lsp exited: %s" (string-trim event))
    (my-ts-lsp--cleanup-state)))

(defun my-ts-lsp--drain-read-buffer ()
  "Parse as many complete LSP messages as possible."
  (let (done)
    (while (not done)
      (let ((header-end (string-match "\r\n\r\n" my-ts-lsp--read-buffer)))
        (if (not header-end)
            (setq done t)
          (let* ((header (substring my-ts-lsp--read-buffer 0 header-end))
                 (content-length (my-ts-lsp--content-length header))
                 (body-start (+ header-end 4))
                 (body-end (+ body-start content-length)))
            (if (> body-end (length my-ts-lsp--read-buffer))
                (setq done t)
              (let ((body (substring my-ts-lsp--read-buffer body-start body-end)))
                (setq my-ts-lsp--read-buffer
                      (substring my-ts-lsp--read-buffer body-end))
                (my-ts-lsp--handle-message body)))))))))

(defun my-ts-lsp--content-length (header)
  "Extract Content-Length from HEADER."
  (let ((case-fold-search t))
    (or (cl-loop for line in (split-string header "\r\n" t)
                 when (string-match "^Content-Length: \\([0-9]+\\)$" line)
                 return (string-to-number (match-string 1 line)))
        (error "Missing Content-Length in header: %s" header))))

(defun my-ts-lsp--handle-message (body)
  "Handle one JSON-RPC BODY."
  (let* ((json-object-type 'alist)
         (json-array-type 'list)
         (json-key-type 'symbol)
         (message (json-read-from-string body))
         (id (alist-get 'id message))
         (method (alist-get 'method message)))
    (cond
     (id
      (puthash id message my-ts-lsp--response-table))
     (method
      (let ((handler (gethash method my-ts-lsp--notification-handlers)))
        (when handler
          (funcall handler message)))))))

(defun my-ts-lsp--send (payload)
  "Send one LSP PAYLOAD."
  (let* ((json-encoding-pretty-print nil)
         (body (json-encode payload)))
    (process-send-string
     my-ts-lsp--process
     (format "Content-Length: %d\r\n\r\n%s" (string-bytes body) body))))

(defun my-ts-lsp--notify (method &optional params)
  "Send a JSON-RPC notification METHOD with PARAMS."
  (my-ts-lsp--send
   `((jsonrpc . "2.0")
     (method . ,method)
     (params . ,(or params (make-hash-table))))))

(defun my-ts-lsp--request (method &optional params timeout)
  "Send METHOD with PARAMS and wait up to TIMEOUT seconds."
  (let* ((id (cl-incf my-ts-lsp--next-id))
         (deadline (+ (float-time) (or timeout 5.0))))
    (puthash id nil my-ts-lsp--response-table)
    (my-ts-lsp--send
     `((jsonrpc . "2.0")
       (id . ,id)
       (method . ,method)
       (params . ,(or params (make-hash-table)))))
    (while (and (null (gethash id my-ts-lsp--response-table))
                (my-ts-lsp--live-p)
                (< (float-time) deadline))
      (accept-process-output my-ts-lsp--process 0.1))
    (let ((response (gethash id my-ts-lsp--response-table)))
      (remhash id my-ts-lsp--response-table)
      (cond
       ((null response)
        (error "Timed out waiting for %s" method))
       ((alist-get 'error response)
        (error "LSP %s failed: %S" method (alist-get 'error response)))
       (t
        (alist-get 'result response))))))

(defun my-ts-lsp--start-server (project-dir)
  "Start a language server rooted at PROJECT-DIR."
  (my-ts-lsp--cleanup-state)
  (setq my-ts-lsp--root-dir (directory-file-name (expand-file-name project-dir))
        my-ts-lsp--process
        (make-process
         :name "ts-lsp"
         :buffer (get-buffer-create my-ts-lsp--stdout-buffer)
         :stderr (get-buffer-create my-ts-lsp--stderr-buffer)
         :command (my-ts-lsp--docker-command my-ts-lsp--root-dir)
         :connection-type 'pipe
         :coding 'utf-8-unix
         :noquery t
         :filter #'my-ts-lsp--process-filter
         :sentinel #'my-ts-lsp--process-sentinel)))

(defun my-ts-lsp--ensure-server ()
  "Ensure a matching language server is running for the current buffer."
  (let ((project-dir (directory-file-name (expand-file-name (my-ts-lsp--project-root)))))
    (unless (and (my-ts-lsp--live-p)
                 my-ts-lsp--initialized
                 (equal project-dir my-ts-lsp--root-dir))
      (when (my-ts-lsp--live-p)
        (delete-process my-ts-lsp--process))
      (my-ts-lsp--start-server project-dir)
      (my-ts-lsp--initialize project-dir))))

(defun my-ts-lsp--initialize (project-dir)
  "Run initialize/initialized for PROJECT-DIR."
  (let ((root-uri (my-ts-lsp--file-uri project-dir))
        (root-name (file-name-nondirectory
                    (directory-file-name project-dir))))
    (my-ts-lsp--request
     "initialize"
     `((processId . nil)
       (clientInfo . ((name . "my-ts-lsp")
                      (version . "0.1")))
       (rootUri . ,root-uri)
       (capabilities
        . ((textDocument
            . ((definition . ((linkSupport . t)))
               (synchronization
                . ((didSave . t)
                   (dynamicRegistration . :json-false)))))
           (workspace . ((workspaceFolders . t)))))
       (workspaceFolders . [((uri . ,root-uri)
                             (name . ,root-name))]))))
  (my-ts-lsp--notify "initialized" (make-hash-table))
  (setq my-ts-lsp--initialized t))

(defun my-ts-lsp--buffer-language-id ()
  "Return the LSP language id for the current buffer."
  (cond
   ((derived-mode-p 'tsx-ts-mode) "typescriptreact")
   ((derived-mode-p 'typescript-ts-mode 'typescript-mode) "typescript")
   ((derived-mode-p 'js-ts-mode 'js-mode) "javascript")
   ((derived-mode-p 'jsx-ts-mode) "javascriptreact")
   (t "typescript")))

(defun my-ts-lsp--current-position ()
  "Return the current point as an LSP position alist."
  (save-restriction
    (widen)
    (let ((line (1- (line-number-at-pos)))
          (character (current-column)))
      `((line . ,line)
        (character . ,character)))))

(defun my-ts-lsp--sync-buffer ()
  "Synchronize the current buffer contents with the server."
  (my-ts-lsp--ensure-server)
  (let* ((file-name (buffer-file-name))
         (uri (my-ts-lsp--file-uri file-name))
         (version (1+ (gethash file-name my-ts-lsp--opened-files 0)))
         (text (buffer-substring-no-properties (point-min) (point-max))))
    (puthash file-name version my-ts-lsp--opened-files)
    (if (= version 1)
        (my-ts-lsp--notify
         "textDocument/didOpen"
         `((textDocument . ((uri . ,uri)
                            (languageId . ,(my-ts-lsp--buffer-language-id))
                            (version . ,version)
                            (text . ,text)))))
      (my-ts-lsp--notify
       "textDocument/didChange"
       `((textDocument . ((uri . ,uri)
                          (version . ,version)))
         (contentChanges . [((text . ,text))]))))
    (setq my-ts-lsp--managed-buffer t)))

(defun my-ts-lsp--did-close ()
  "Notify the server that the current buffer has closed."
  (when (and my-ts-lsp--managed-buffer
             (buffer-file-name)
             my-ts-lsp--initialized)
    (let ((file-name (buffer-file-name)))
      (remhash file-name my-ts-lsp--opened-files)
      (my-ts-lsp--notify
       "textDocument/didClose"
       `((textDocument . ((uri . ,(my-ts-lsp--file-uri file-name))))))
      (setq my-ts-lsp--managed-buffer nil))))

(defun my-ts-lsp--location-marker (location)
  "Convert one LSP LOCATION to an xref marker."
  (let* ((uri (or (alist-get 'targetUri location)
                  (alist-get 'uri location)))
         (range (or (alist-get 'targetSelectionRange location)
                    (alist-get 'targetRange location)
                    (alist-get 'range location)))
         (start (alist-get 'start range))
         (file (my-ts-lsp--uri-path uri))
         (line (1+ (alist-get 'line start)))
         (character (alist-get 'character start))
         (buffer (find-file-noselect file)))
    (with-current-buffer buffer
      (save-excursion
        (goto-char (point-min))
        (forward-line (1- line))
        (move-to-column character)
        (point-marker)))))

(defun my-ts-lsp--location-xref (location)
  "Convert one LSP LOCATION to an xref item."
  (let* ((marker (my-ts-lsp--location-marker location))
         (buffer (marker-buffer marker))
         (line-text (with-current-buffer buffer
                      (save-excursion
                        (goto-char marker)
                        (buffer-substring-no-properties
                         (line-beginning-position)
                         (line-end-position))))))
    (xref-make (string-trim line-text)
               (xref-make-file-location
                (buffer-file-name buffer)
                (line-number-at-pos marker)
                (save-excursion
                  (goto-char marker)
                  (current-column))))))

(defun my-ts-lsp--normalize-locations (result)
  "Normalize RESULT from textDocument/definition into a list."
  (cond
   ((null result) nil)
   ((and (listp result) (alist-get 'uri result)) (list result))
   ((and (listp result) (alist-get 'targetUri result)) (list result))
   ((listp result) result)
   (t nil)))

(defun my-ts-lsp--definition-xrefs ()
  "Return xrefs for the symbol at point."
  (my-ts-lsp--sync-buffer)
  (let* ((result
          (my-ts-lsp--request
           "textDocument/definition"
           `((textDocument . ((uri . ,(my-ts-lsp--file-uri (buffer-file-name)))))
             (position . ,(my-ts-lsp--current-position)))))
         (locations (my-ts-lsp--normalize-locations result)))
    (mapcar #'my-ts-lsp--location-xref locations)))

(defun my-ts-lsp--reference-xrefs ()
  "Return xrefs for references to the symbol at point."
  (my-ts-lsp--sync-buffer)
  (let* ((result
          (my-ts-lsp--request
           "textDocument/references"
           `((textDocument . ((uri . ,(my-ts-lsp--file-uri (buffer-file-name)))))
             (position . ,(my-ts-lsp--current-position))
             (context . ((includeDeclaration . t))))))
         (locations (my-ts-lsp--normalize-locations result)))
    (mapcar #'my-ts-lsp--location-xref locations)))

(cl-defmethod xref-backend-identifier-at-point ((_backend (eql my-ts-lsp)))
  (thing-at-point 'symbol t))

(cl-defmethod xref-backend-identifier-completion-table ((_backend (eql my-ts-lsp)))
  nil)

(cl-defmethod xref-backend-definitions ((_backend (eql my-ts-lsp)) _identifier)
  (my-ts-lsp--definition-xrefs))

(cl-defmethod xref-backend-references ((_backend (eql my-ts-lsp)) _identifier)
  (my-ts-lsp--reference-xrefs))

(defun my-ts-lsp-xref-backend ()
  "Return the xref backend for the current buffer."
  (when (and buffer-file-name
             (derived-mode-p 'typescript-ts-mode
                             'tsx-ts-mode
                             'typescript-mode
                             'js-ts-mode
                             'js-mode
                             'jsx-ts-mode)
             (ignore-errors (my-ts-lsp--project-root)))
    'my-ts-lsp))

(define-minor-mode my-ts-lsp-mode
  "Use a minimal TypeScript LSP xref backend over stdio."
  :lighter " my-ts-lsp"
  (if my-ts-lsp-mode
      (progn
        (add-hook 'xref-backend-functions #'my-ts-lsp-xref-backend nil t)
        (add-hook 'kill-buffer-hook #'my-ts-lsp--did-close nil t))
    (remove-hook 'xref-backend-functions #'my-ts-lsp-xref-backend t)
    (remove-hook 'kill-buffer-hook #'my-ts-lsp--did-close t)
    (my-ts-lsp--did-close)))

(defun my-ts-lsp-start ()
  "Enable `my-ts-lsp-mode' in the current buffer."
  (interactive)
  (my-ts-lsp-mode 1))

(defun my-ts-lsp-stop ()
  "Disable `my-ts-lsp-mode' and stop the shared server."
  (interactive)
  (my-ts-lsp-mode -1)
  (when (my-ts-lsp--live-p)
    (delete-process my-ts-lsp--process))
  (my-ts-lsp--cleanup-state))

(provide 'my-lsp)

;;; my-lsp.el ends here