Skip to content

Commit

Permalink
Run pcase-defmacro for interfaces (#2481)
Browse files Browse the repository at this point in the history 
* Run pcase-defmacro for interfaces

* Use new pcase patterns
  • Loading branch information
@leungbk
leungbk authored Dec 30, 2020
1 parent 8d87e88 commit 6bf62bd
Show file tree
Hide file tree
Showing 3 changed files with 206 additions and 18 deletions.
33 changes: 16 additions & 17 deletions lsp-mode.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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 ()
Expand Down
96 changes: 96 additions & 0 deletions lsp-protocol.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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"
Expand Down
95 changes: 94 additions & 1 deletion test/lsp-protocol-test.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)))
Expand Down Expand Up @@ -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

0 comments on commit 6bf62bd

Please sign in to comment.