From 6bf62bd02da0500df8d638203326ed1d1cbb7521 Mon Sep 17 00:00:00 2001 From: Brian Leung <29217594+leungbk@users.noreply.github.com> Date: Wed, 30 Dec 2020 05:17:01 -0800 Subject: [PATCH] Run pcase-defmacro for interfaces (#2481) * Run pcase-defmacro for interfaces * Use new pcase patterns --- lsp-mode.el | 33 +++++++------- lsp-protocol.el | 96 +++++++++++++++++++++++++++++++++++++++ test/lsp-protocol-test.el | 95 +++++++++++++++++++++++++++++++++++++- 3 files changed, 206 insertions(+), 18 deletions(-) diff --git a/lsp-mode.el b/lsp-mode.el index 7c84a472676..faaa5498b9d 100644 --- a/lsp-mode.el +++ b/lsp-mode.el @@ -4434,12 +4434,13 @@ and the position respectively." "Return a list of `xref-item' given LOCATIONS, which can be of type Location, LocationLink, Location[] or LocationLink[]." (setq locations - (if (and (sequencep locations) - (let ((fst (lsp-seq-first locations))) - (or (lsp-location? fst) - (lsp-location-link? fst)))) - (append locations nil) - (when locations (list locations)))) + (pcase locations + ((seq (or (Location) + (LocationLink))) + (append locations nil)) + ((or (Location) + (LocationLink)) + (list locations)))) (cl-labels ((get-xrefs-in-file (file-locs) @@ -4707,17 +4708,15 @@ When language is nil render as markup if `markdown-mode' is loaded." "Render CONTENT element." (let ((inhibit-message t)) (or - (cond - ((lsp-marked-string? content) - (-let [(&MarkedString :language :value) content] - (lsp--render-string value language))) - ((lsp-markup-content? content) - (-let [(&MarkupContent :value :kind) content] - (lsp--render-string value kind))) - ;; plain string - ((stringp content) (lsp--render-string content "markdown")) - ((null content) "") - (t (error "Failed to handle %s" content))) + (pcase content + ((MarkedString :value :language) + (lsp--render-string value language)) + ((MarkupContent :value :kind) + (lsp--render-string value kind)) + ;; plain string + ((pred stringp) (lsp--render-string content "markdown")) + ((pred null) "") + (_ (error "Failed to handle %s" content))) ""))) (defun lsp--create-unique-string-fn () diff --git a/lsp-protocol.el b/lsp-protocol.el index 514fc568485..cab97920ab7 100644 --- a/lsp-protocol.el +++ b/lsp-protocol.el @@ -127,6 +127,102 @@ Allowed params: %s" interface (reverse (-map #'cl-first params))) $$result)) (-partition 2 plist)) $$result))) + `(pcase-defmacro ,interface (&rest property-bindings) + ,(if lsp-use-plists + ``(and + (pred listp) + ;; Check if all the types required by the + ;; interface exist in the expr-val. + ,@(-map + (lambda (key) + `(pred + (lambda (plist) + (plist-member plist ,key)))) + ',required) + ;; Recursively generate the bindings. + ,@(let ((current-list property-bindings) + (output-bindings nil)) + ;; Invariant: while current-list is + ;; non-nil, the car of current-list is + ;; always of the form :key, while the + ;; cadr of current-list is either a) + ;; nil, b) of the form :key-next or c) + ;; a pcase pattern that can + ;; recursively match an expression. + (while current-list + (-let* (((curr-binding-as-keyword next-entry . _) current-list) + (curr-binding-as-camelcased-symbol + (or (alist-get curr-binding-as-keyword ',params) + (error "Unknown key: %s. Available keys: %s" + (symbol-name curr-binding-as-keyword) + ',(-map #'cl-first params)))) + (bound-name (lsp-keyword->symbol curr-binding-as-keyword)) + (next-entry-is-key-or-nil + (and (symbolp next-entry) + (or (null next-entry) + (s-starts-with? ":" (symbol-name next-entry)))))) + (cond + ;; If the next-entry is either a + ;; plist-key or nil, then bind to + ;; bound-name the value corresponding + ;; to the camelcased symbol. Pop + ;; current-list once. + (next-entry-is-key-or-nil + (push `(app (lambda (plist) + (plist-get plist ,curr-binding-as-camelcased-symbol)) + ,bound-name) + output-bindings) + (setf current-list (cdr current-list))) + ;; Otherwise, next-entry is a pcase + ;; pattern we recursively match to the + ;; expression. This can in general + ;; create additional bindings that we + ;; persist in the top level of + ;; bindings. We pop current-list + ;; twice. + (t + (push `(app (lambda (plist) + (plist-get plist ,curr-binding-as-camelcased-symbol)) + ,next-entry) + output-bindings) + (setf current-list (cddr current-list)))))) + output-bindings)) + ``(and + (pred ht?) + ,@(-map + (lambda (key) + `(pred + (lambda (hash-table) + (ht-contains? hash-table ,(lsp-keyword->string key))))) + ',required) + ,@(let ((current-list property-bindings) + (output-bindings nil)) + (while current-list + (-let* (((curr-binding-as-keyword next-entry . _) current-list) + (curr-binding-as-camelcased-string + (lsp-keyword->string (or (alist-get curr-binding-as-keyword ',params) + (error "Unknown key: %s. Available keys: %s" + (symbol-name curr-binding-as-keyword) + ',(-map #'cl-first params))))) + (bound-name (lsp-keyword->symbol curr-binding-as-keyword)) + (next-entry-is-key-or-nil + (and (symbolp next-entry) + (or (null next-entry) + (s-starts-with? ":" (symbol-name next-entry)))))) + (cond + (next-entry-is-key-or-nil + (push `(app (lambda (hash-table) + (ht-get hash-table ,curr-binding-as-camelcased-string)) + ,bound-name) + output-bindings) + (setf current-list (cdr current-list))) + (t + (push `(app (lambda (hash-table) + (ht-get hash-table ,curr-binding-as-camelcased-string)) + ,next-entry) + output-bindings) + (setf current-list (cddr current-list)))))) + output-bindings)))) (-mapcat (-lambda ((label . name)) (list `(defun ,(intern (format "lsp:%s-%s" diff --git a/test/lsp-protocol-test.el b/test/lsp-protocol-test.el index ce76ec49d32..2694d566a59 100644 --- a/test/lsp-protocol-test.el +++ b/test/lsp-protocol-test.el @@ -27,9 +27,12 @@ (require 'lsp-protocol) (require 'ert) +(require 'seq) (eval-and-compile - (lsp-interface (MyPosition (:line :character :camelCase) (:optional)))) + (lsp-interface (MyPosition (:line :character :camelCase) (:optional))) + (lsp-interface (MyRange (:start :end) nil)) + (lsp-interface (MyExtendedRange (:start :end :specialProperty) nil))) (ert-deftest lsp-test-lsp-interface () (let ((position (lsp-make-my-position :character 1 :line 2))) @@ -66,5 +69,95 @@ (should (lsp-my-position? (lsp-make-my-position :character nil :line 2 :camelCase nil))))) +(ert-deftest lsp-test-pcase-patterns () + (let ((particular-range (lsp-make-my-range :start + (lsp-make-my-position :line 10 :character 20 :camelCase nil) + :end + (lsp-make-my-position :line 30 :character 40 :camelCase nil))) + (particular-extended-range + (lsp-make-my-extended-range :start + (lsp-make-my-position :line 10 :character 20 :camelCase nil) + :end + (lsp-make-my-position :line 30 :character 40 :camelCase nil) + :specialProperty 42))) + (should (pcase particular-range + ((MyRange :start (MyPosition :line start-line :character start-char :camel-case start-camelcase) + :end (MyPosition :line end-line :character end-char :camel-case end-camelCase)) + t) + (_ nil))) + + (should (pcase particular-extended-range + ((MyExtendedRange) + t) + (_ nil))) + + ;; a subclass can be matched by a pattern for a parent class + (should (pcase particular-extended-range + ((MyRange :start (MyPosition :line start-line :character start-char :camel-case start-camelcase) + :end (MyPosition :line end-line :character end-char :camel-case end-camelCase)) + t) + (_ nil))) + + ;; the new patterns should be able to be used with existing ones + (should (pcase (list particular-range + particular-extended-range) + ((seq (MyRange) + (MyExtendedRange)) + t) + (_ nil))) + + ;; the existing seq pattern should detect that the ranges are + ;; not in the order specified by the inner patterns + (should-not (pcase (list particular-range + particular-extended-range) + ((seq (MyExtendedRange) + (MyRange)) + t) + (_ nil))) + + ;; when a binding appears more than once, then the first + ;; occurrence binds if it can match, and the subsequent + ;; occurrences turn into equality checks. Since :character + ;; appears twice as a key name, the first instance binds it to 20, + ;; and the second instance is an equality check against the other + ;; :character value, which is different. + (should-not (pcase particular-range + ((MyRange :start (MyPosition :line start-line :character :camel-case start-camelcase) + :end (MyPosition :line end-line :character :camel-case end-camelCase)) + t) + (_ nil))) + + ;; if an optional property is requested when it does not exist, we + ;; should still match if the required stuff matches. Missing + ;; optional properties are bound to nil. + (should (pcase particular-range + ((MyRange :start (MyPosition :optional?)) + (null optional?)) + (_ nil))) + + ;; we cannot request a key (whether or not it is optional) not in + ;; the interface, even if the expr-val has all the types specified + ;; by the interface. This is a programmer error. + (should-error (pcase particular-range + ((MyRange :something-unrelated) + t) + (_ nil))) + + ;; we do not use camelCase at this stage. This is a programmer error. + (should-error (pcase particular-range + ((MyRange :start (MyPosition :camelCase)) + t) + (_ nil))) + (should (pcase particular-range + ((MyRange :start (MyPosition :camel-case)) + t) + (_ nil))) + + ;; :end is missing, so we should fail to match the interface. + (should-not (pcase (lsp-make-my-range :start (lsp-make-my-position :line 10 :character 20 :camelCase nil)) + ((MyRange) + t) + (_ nil))))) + (provide 'lsp-protocol-test) ;;; lsp-protocol-test.el ends here