|
| 1 | +;;; eglot-fsharp-integration-util.el --- Helper for eglot integration tests -*- lexical-binding: t; -*- |
| 2 | + |
| 3 | +;; Copyright (C) 2022 Jürgen Hötzel |
| 4 | + |
| 5 | +;; Author: Jürgen Hötzel <[email protected]> |
| 6 | +;; Keywords: processes |
| 7 | + |
| 8 | +;; This program is free software; you can redistribute it and/or modify |
| 9 | +;; it under the terms of the GNU General Public License as published by |
| 10 | +;; the Free Software Foundation, either version 3 of the License, or |
| 11 | +;; (at your option) any later version. |
| 12 | + |
| 13 | +;; This program is distributed in the hope that it will be useful, |
| 14 | +;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 15 | +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 16 | +;; GNU General Public License for more details. |
| 17 | + |
| 18 | +;; You should have received a copy of the GNU General Public License |
| 19 | +;; along with this program. If not, see <https://www.gnu.org/licenses/>. |
| 20 | + |
| 21 | +;;; Commentary: |
| 22 | + |
| 23 | +;; |
| 24 | + |
| 25 | +;;; Code: |
| 26 | +(require 'edebug) |
| 27 | + |
| 28 | +(cl-defmacro eglot-fsharp--with-timeout (timeout &body body) |
| 29 | + (declare (indent 1) (debug t)) |
| 30 | + `(eglot-fsharp--call-with-timeout ,timeout (lambda () ,@body))) |
| 31 | + |
| 32 | +(defun eglot-fsharp--call-with-timeout (timeout fn) |
| 33 | + (let* ((tag (gensym "eglot-test-timeout")) |
| 34 | + (timed-out (make-symbol "timeout")) |
| 35 | + (timeout-and-message |
| 36 | + (if (listp timeout) timeout |
| 37 | + (list timeout "waiting for test to finish"))) |
| 38 | + (timeout (car timeout-and-message)) |
| 39 | + (message (cadr timeout-and-message)) |
| 40 | + (timer) |
| 41 | + (retval)) |
| 42 | + (unwind-protect |
| 43 | + (setq retval |
| 44 | + (catch tag |
| 45 | + (setq timer |
| 46 | + (run-with-timer timeout nil |
| 47 | + (lambda () |
| 48 | + (unless edebug-active |
| 49 | + (throw tag timed-out))))) |
| 50 | + (funcall fn))) |
| 51 | + (cancel-timer timer) |
| 52 | + (when (eq retval timed-out) |
| 53 | + (warn "Received Events for %s : %s" |
| 54 | + (file-name-nondirectory (buffer-file-name)) |
| 55 | + (with-current-buffer (jsonrpc-events-buffer (eglot-current-server)) (buffer-string))) |
| 56 | + (error "%s" (concat "Timed out " message)))))) |
| 57 | + |
| 58 | + |
| 59 | +(defun eglot-fsharp--find-file-noselect (file &optional noerror) |
| 60 | + (unless (or noerror |
| 61 | + (file-readable-p file)) (error "%s does not exist" file)) |
| 62 | + (find-file-noselect file)) |
| 63 | + |
| 64 | +(defun eglot-fsharp--tests-connect (&optional timeout) |
| 65 | + (let* ((timeout (or timeout 10)) |
| 66 | + (eglot-sync-connect t) |
| 67 | + (eglot-connect-timeout timeout)) |
| 68 | + (apply #'eglot--connect (eglot--guess-contact)))) |
| 69 | + |
| 70 | +(cl-defmacro eglot-fsharp--wait-for ((events-sym &optional (timeout 1) message) args &body body) |
| 71 | + "Spin until FN match in EVENTS-SYM, flush events after it. |
| 72 | +Pass TIMEOUT to `eglot--with-timeout'." |
| 73 | + (declare (indent 2) (debug (sexp sexp sexp &rest form))) |
| 74 | + `(eglot-fsharp--with-timeout '(,timeout ,(or message |
| 75 | + (format "waiting for:\n%s" (pp-to-string body)))) |
| 76 | + (let ((event |
| 77 | + (cl-loop thereis (cl-loop for json in ,events-sym |
| 78 | + for method = (plist-get json :method) |
| 79 | + when (keywordp method) |
| 80 | + do (plist-put json :method |
| 81 | + (substring |
| 82 | + (symbol-name method) |
| 83 | + 1)) |
| 84 | + when (funcall |
| 85 | + (jsonrpc-lambda ,args ,@body) json) |
| 86 | + return (cons json before) |
| 87 | + collect json into before) |
| 88 | + for i from 0 |
| 89 | + when (zerop (mod i 5)) |
| 90 | + ;; do (eglot--message "still struggling to find in %s" |
| 91 | + ;; ,events-sym) |
| 92 | + do |
| 93 | + ;; `read-event' is essential to have the file |
| 94 | + ;; watchers come through. |
| 95 | + (read-event "[eglot] Waiting a bit..." nil 0.1) |
| 96 | + (accept-process-output nil 0.1)))) |
| 97 | + (setq ,events-sym (cdr event)) |
| 98 | + (eglot--message "Event detected:\n%s" |
| 99 | + (pp-to-string (car event)))))) |
| 100 | + |
| 101 | + |
| 102 | +(cl-defmacro eglot-fsharp--sniffing ((&key server-requests |
| 103 | + server-notifications |
| 104 | + server-replies |
| 105 | + client-requests |
| 106 | + client-notifications |
| 107 | + client-replies) |
| 108 | + &rest body) |
| 109 | + "Run BODY saving LSP JSON messages in variables, most recent first." |
| 110 | + (declare (indent 1) (debug (sexp &rest form))) |
| 111 | + (let ((log-event-ad-sym (make-symbol "eglot-fsharp--event-sniff"))) |
| 112 | + `(unwind-protect |
| 113 | + (let ,(delq nil (list server-requests |
| 114 | + server-notifications |
| 115 | + server-replies |
| 116 | + client-requests |
| 117 | + client-notifications |
| 118 | + client-replies)) |
| 119 | + (advice-add |
| 120 | + #'jsonrpc--log-event :before |
| 121 | + (lambda (_proc message &optional type) |
| 122 | + (cl-destructuring-bind (&key method id _error &allow-other-keys) |
| 123 | + message |
| 124 | + (let ((req-p (and method id)) |
| 125 | + (notif-p method) |
| 126 | + (reply-p id)) |
| 127 | + (cond |
| 128 | + ((eq type 'server) |
| 129 | + (cond (req-p ,(when server-requests |
| 130 | + `(push message ,server-requests))) |
| 131 | + (notif-p ,(when server-notifications |
| 132 | + `(push message ,server-notifications))) |
| 133 | + (reply-p ,(when server-replies |
| 134 | + `(push message ,server-replies))))) |
| 135 | + ((eq type 'client) |
| 136 | + (cond (req-p ,(when client-requests |
| 137 | + `(push message ,client-requests))) |
| 138 | + (notif-p ,(when client-notifications |
| 139 | + `(push message ,client-notifications))) |
| 140 | + (reply-p ,(when client-replies |
| 141 | + `(push message ,client-replies))))))))) |
| 142 | + '((name . ,log-event-ad-sym))) |
| 143 | + ,@body) |
| 144 | + (advice-remove #'jsonrpc--log-event ',log-event-ad-sym)))) |
| 145 | + |
| 146 | + |
| 147 | + |
| 148 | +(defun eglot-fsharp--sniff-diagnostics (file-name-suffix) |
| 149 | + (eglot-fsharp--sniffing (:server-notifications s-notifs) |
| 150 | + (eglot-fsharp--wait-for (s-notifs 20) |
| 151 | + (&key _id method params &allow-other-keys) |
| 152 | + (and |
| 153 | + (string= method "textDocument/publishDiagnostics") |
| 154 | + (string-suffix-p file-name-suffix (plist-get params :uri)))))) |
| 155 | + |
| 156 | +(defun eglot-fsharp--sniff-method (method-name) |
| 157 | + (eglot-fsharp--sniffing (:server-notifications s-notifs) |
| 158 | + (eglot-fsharp--wait-for (s-notifs 20) |
| 159 | + (&key _id method params &allow-other-keys) |
| 160 | + (and |
| 161 | + (string= method method-name))))) |
| 162 | + |
| 163 | +(provide 'eglot-fsharp-integration-util) |
| 164 | +;;; integration-util.el ends here |
0 commit comments