relic: 2026-09-18T13:50:31+02:00

1 files changed, 267 insertions, 14 deletions

diff --git a/lisp/citre-backend.el b/lisp/citre-backend.el
index 8c50c6d..eefdd31 100644
--- a/lisp/citre-backend.el
+++ b/lisp/citre-backend.el
@@ -3,6 +3,42 @@
 (require 'citre)
 (require 'citre-tags)
 (require 'citre-index)
+(require 'subr-x)
+
+(defcustom my/citre-completion-deduplication 'name
+  "How Citre completion candidates are deduplicated.
+The value `name' keeps one ranked candidate for each insertion text.  Nil keeps every tag returned by Citre."
+  :type '(choice (const :tag "One candidate per name" name)
+                 (const :tag "Keep every tag" nil))
+  :group 'my/citre)
+
+(defcustom my/citre-completion-context-filter 'safe
+  "How receiver context affects Citre completions.
+The value `safe' filters by an explicitly declared receiver type only when at least one returned tag matches it.  Nil only uses context for ranking."
+  :type '(choice (const :tag "Filter only verified receiver types" safe)
+                 (const :tag "Only rank by context" nil))
+  :group 'my/citre)
+
+(defcustom my/citre-completion-source-order
+  '(current-buffer live-buffer project dependency tags-file)
+  "Preferred source order for Citre completion candidates."
+  :type '(repeat (choice (const current-buffer) (const live-buffer)
+                         (const project) (const dependency) (const tags-file)))
+  :group 'my/citre)
+
+(defcustom my/citre-completion-annotation '(scope source count)
+  "Components shown after a Citre completion candidate."
+  :type '(set (const scope) (const source) (const count))
+  :group 'my/citre)
+
+(defcustom my/citre-completion-type-resolvers
+  '(my/citre-backend--resolve-go-type
+    my/citre-backend--resolve-rust-or-python-type
+    my/citre-backend--resolve-c-type)
+  "Functions used in order to resolve an explicitly declared receiver type.
+Each function receives a receiver name and the beginning of its member expression and returns a type name or nil."
+  :type 'hook
+  :group 'my/citre)
 
 (defvar company--capf-cache)
 (defvar-local my/citre-backend--completion-cache nil)
@@ -13,29 +49,40 @@
   (set 'my/citre-backend--company-timer nil))
 
 (defun my/citre-backend--sources ()
-  "Return (TAGS-FILE . LIVE-SOURCE) pairs in priority order."
+  "Return tag source plists in priority order."
   (if-let* ((state my/citre-index--state))
       (let* ((entries (my/citre-index-live-entries state))
              (current (my/citre-index--path))
              (live (sort entries (lambda (a b) (and (equal (car a) current) (not (equal (car b) current)))))))
         (append
-         (mapcar (lambda (entry) (cons (plist-get (cdr entry) :file) (car entry))) live)
+         (mapcar (lambda (entry)
+                   (list :file (plist-get (cdr entry) :file)
+                         :live-source (car entry)
+                         :source (if (equal (car entry) current) 'current-buffer 'live-buffer)))
+                 live)
          (let ((project (expand-file-name "project.tags" (my/citre-index-state-cache state))))
            (if (file-readable-p project)
-               (list (cons project nil))
-             (when-let* ((legacy (citre-tags-file-path))) (list (cons legacy nil)))))
+               (list (list :file project :source 'project))
+             (when-let* ((legacy (citre-tags-file-path)))
+               (list (list :file legacy :source 'tags-file)))))
          (let ((dependencies (expand-file-name "dependencies.tags" (my/citre-index-state-cache state))))
-           (when (file-readable-p dependencies) (list (cons dependencies nil))))))
-    (when-let* ((file (citre-tags-file-path))) (list (cons file nil)))))
+           (when (file-readable-p dependencies)
+             (list (list :file dependencies :source 'dependency))))))
+    (when-let* ((file (citre-tags-file-path)))
+      (list (list :file file :source 'tags-file)))))
+
+(defun my/citre-backend--source-rank (source)
+  "Return the configured rank of SOURCE."
+  (or (seq-position my/citre-completion-source-order source) most-positive-fixnum))
 
 (defun my/citre-backend--query (operation &optional identifier)
   "Merge tags for OPERATION, optionally using IDENTIFIER, while masking superseded files."
   (let* ((sources (my/citre-backend--sources))
-         (masked (delq nil (mapcar #'cdr sources)))
+         (masked (delq nil (mapcar (lambda (source) (plist-get source :live-source)) sources)))
          (seen (make-hash-table :test #'equal))
          result)
     (dolist (source sources)
-      (let* ((file (car source))
+      (let* ((file (plist-get source :file))
              (symbol (or (and identifier
                               (citre-put-property (copy-sequence identifier)
                                                   'file-path buffer-file-name 'tags-file file))
@@ -66,29 +113,235 @@
           (let* ((path (citre-get-tag-field 'ext-abspath tag))
                  (key (mapcar (lambda (field) (citre-get-tag-field field tag))
                               '(name ext-abspath line scope ext-kind-full))))
-            (unless (or (and (not (cdr source)) (member path masked)) (gethash key seen))
+            (unless (or (and (not (plist-get source :live-source)) (member path masked))
+                        (gethash key seen))
               (puthash key t seen)
+              (when (eq operation 'completion)
+                (setq tag (copy-hash-table tag))
+                (citre-set-tag-field 'my-source (plist-get source :source) tag)
+                (citre-set-tag-field 'my-order (length result) tag))
               (push tag result))))))
     (nreverse result)))
 
+(defun my/citre-backend--member-context (beginning)
+  "Return the member-access context immediately before BEGINNING."
+  (save-excursion
+    (goto-char beginning)
+    (skip-chars-backward " \t")
+    (let ((end (point)))
+      (when (and (re-search-backward
+                  "\\_<\\([[:alpha:]_][[:alnum:]_]*\\)\\_>[ \t]*\\(\\.\\|->\\|::\\)[ \t]*"
+                  (line-beginning-position) t)
+                 (= (match-end 0) end))
+        (let* ((receiver (match-string-no-properties 1))
+               (operator (match-string-no-properties 2))
+               (type (run-hook-with-args-until-success
+                      'my/citre-completion-type-resolvers receiver beginning)))
+          (list :receiver receiver :operator operator :type type))))))
+
+(defun my/citre-backend--defun-start ()
+  "Return the beginning of the enclosing defun without moving point."
+  (save-excursion
+    (condition-case nil
+        (progn (beginning-of-defun) (point))
+      (error (point-min)))))
+
+(defun my/citre-backend--unique-match (regexp text)
+  "Return the sole normalized type captured by REGEXP in TEXT."
+  (let (matches)
+    (with-temp-buffer
+      (insert text)
+      (goto-char (point-min))
+      (while (re-search-forward regexp nil t)
+        (push (my/citre-backend--normalize-type (match-string-no-properties 1)) matches)))
+    (car (when (= (length (delete-dups (delq nil matches))) 1) matches))))
+
+(defun my/citre-backend--normalize-type (type)
+  "Return a comparable nominal name for TYPE."
+  (when type
+    (let ((value (string-trim type)))
+      (setq value (replace-regexp-in-string "\\_<\\(?:const\\|volatile\\|mut\\|struct\\|class\\|enum\\|dyn\\)\\_>" "" value)
+            value (replace-regexp-in-string "[&*[:space:]]" "" value)
+            value (replace-regexp-in-string "<.*>\\'" "" value)
+            value (replace-regexp-in-string "::" "." value))
+      (unless (string-empty-p value) value))))
+
+(defun my/citre-backend--context-text (beginning)
+  "Return text from the enclosing defun through BEGINNING."
+  (buffer-substring-no-properties (my/citre-backend--defun-start) beginning))
+
+(defun my/citre-backend--resolve-go-type (receiver beginning)
+  "Resolve RECEIVER from an explicit Go declaration before BEGINNING."
+  (when (derived-mode-p 'go-mode 'go-ts-mode)
+    (let* ((text (my/citre-backend--context-text beginning))
+           (name (regexp-quote receiver))
+           (regexp (format "\\(?:\\_<var[ \t]+%s\\_>\\|[,( \t\n]%s\\_>\\)[ \t]+\\(\\*?[[:alpha:]_][[:alnum:]_./]*\\)" name name)))
+      (my/citre-backend--unique-match regexp text))))
+
+(defun my/citre-backend--resolve-rust-or-python-type (receiver beginning)
+  "Resolve an explicitly annotated Rust or Python RECEIVER before BEGINNING."
+  (when (or (derived-mode-p 'rust-mode 'rust-ts-mode)
+            (derived-mode-p 'python-mode 'python-ts-mode))
+    (let* ((text (my/citre-backend--context-text beginning))
+           (regexp (format "\\_<%s\\_>[ \t]*:[ \t]*\\(?:&[ \t]*\\)?\\(?:mut[ \t]+\\)?\\([[:alpha:]_][[:alnum:]_.:]*\\(?:<[^>\n]+>\\)?\\)"
+                           (regexp-quote receiver))))
+      (my/citre-backend--unique-match regexp text))))
+
+(defun my/citre-backend--resolve-c-type (receiver beginning)
+  "Resolve RECEIVER from a simple explicit C or C++ declaration."
+  (when (derived-mode-p 'c-mode 'c-ts-mode 'c++-mode 'c++-ts-mode)
+    (let* ((text (my/citre-backend--context-text beginning))
+           (regexp (format "\\(?:[(,;{]\\|^\\)[ \t\n]*\\(?:const[ \t]+\\)?\\(?:struct[ \t]+\\)?\\([[:alpha:]_][[:alnum:]_:]*\\(?:[ \t]*<[^>;\n]+>\\)?\\)[ \t*&]+%s\\_>"
+                           (regexp-quote receiver))))
+      (my/citre-backend--unique-match regexp text))))
+
+(defun my/citre-backend--tag-scope (tag)
+  "Return TAG's compact normalized scope."
+  (my/citre-backend--normalize-type (citre-get-tag-field 'scope tag t)))
+
+(defun my/citre-backend--scope-match-p (type tag)
+  "Whether the nominal TYPE matches TAG's scope."
+  (when-let* ((type (my/citre-backend--normalize-type type))
+              (scope (my/citre-backend--tag-scope tag)))
+    (or (equal scope type)
+        (string-suffix-p (concat "." type) scope)
+        (and (not (string-match-p "\\." type))
+             (equal type (car (last (split-string scope "\\." t))))))))
+
+(defun my/citre-backend--same-directory-p (tag)
+  "Whether TAG belongs to the current file's directory."
+  (when-let* ((current buffer-file-name)
+              (path (citre-get-tag-field 'ext-abspath tag)))
+    (equal (file-name-directory (file-truename current))
+           (file-name-directory (file-truename path)))))
+
+(defun my/citre-backend--current-scope ()
+  "Return the current defun name when Emacs can determine it cheaply."
+  (when (fboundp 'add-log-current-defun)
+    (ignore-errors (add-log-current-defun))))
+
+(defun my/citre-backend--tag-rank (tag context current-scope)
+  "Return a lexicographically comparable rank for TAG in CONTEXT."
+  (let* ((path (citre-get-tag-field 'ext-abspath tag))
+         (scope (my/citre-backend--tag-scope tag))
+         (type (plist-get context :type)))
+    (list (if (my/citre-backend--scope-match-p type tag) 0 1)
+          (if (and path buffer-file-name (equal (file-truename path) (file-truename buffer-file-name))) 0 1)
+          (if (and current-scope scope (string-match-p (regexp-quote current-scope) scope)) 0 1)
+          (if (my/citre-backend--same-directory-p tag) 0 1)
+          (my/citre-backend--source-rank (citre-get-tag-field 'my-source tag))
+          (or (citre-get-tag-field 'my-order tag) most-positive-fixnum))))
+
+(defun my/citre-backend--rank-less-p (left right context current-scope)
+  "Whether LEFT should sort before RIGHT in CONTEXT."
+  (let ((a (my/citre-backend--tag-rank left context current-scope))
+        (b (my/citre-backend--tag-rank right context current-scope)))
+    (catch 'result
+      (while a
+        (unless (= (car a) (car b))
+          (throw 'result (< (car a) (car b))))
+        (setq a (cdr a) b (cdr b)))
+      nil)))
+
+(defun my/citre-backend--prepare-completions (tags context)
+  "Context-filter, rank and deduplicate completion TAGS."
+  (let* ((type (plist-get context :type))
+         (matching (and type (seq-filter (lambda (tag) (my/citre-backend--scope-match-p type tag)) tags)))
+         (visible (if (and (eq my/citre-completion-context-filter 'safe) matching) matching tags))
+         (groups (make-hash-table :test #'equal))
+         (current-scope (my/citre-backend--current-scope)))
+    (dolist (tag tags)
+      (push tag (gethash (citre-get-tag-field 'name tag) groups)))
+    (setq visible (sort visible (lambda (a b) (my/citre-backend--rank-less-p a b context current-scope))))
+    (if (not (eq my/citre-completion-deduplication 'name))
+        visible
+      (let ((seen (make-hash-table :test #'equal)) result)
+        (dolist (tag visible (nreverse result))
+          (let ((name (citre-get-tag-field 'name tag)))
+            (unless (gethash name seen)
+              (puthash name t seen)
+              (citre-set-tag-field 'my-tags (nreverse (gethash name groups)) tag)
+              (citre-set-tag-field 'my-count (length (citre-get-tag-field 'my-tags tag)) tag)
+              (push tag result))))))))
+
+(defun my/citre-backend--source-label (source)
+  "Return a compact display label for SOURCE."
+  (alist-get source '((current-buffer . "buf") (live-buffer . "live")
+                      (project . "proj") (dependency . "dep") (tags-file . "tags"))))
+
+(defun my/citre-backend--annotation (tag)
+  "Return the compact completion annotation for TAG."
+  (let ((count (or (citre-get-tag-field 'my-count tag) 1)) parts)
+    (when (memq 'scope my/citre-completion-annotation)
+      (when-let* ((scope (my/citre-backend--tag-scope tag))) (push scope parts)))
+    (when (memq 'source my/citre-completion-annotation)
+      (when-let* ((source (my/citre-backend--source-label (citre-get-tag-field 'my-source tag))))
+        (push source parts)))
+    (when (and (memq 'count my/citre-completion-annotation) (> count 1))
+      (push (format "+%d" (1- count)) parts))
+    (when parts (concat " " (string-join (nreverse parts) " · ")))))
+
+(defun my/citre-backend--make-candidate (tag)
+  "Make one Company/CAPF candidate from TAG."
+  (citre-put-property
+   (citre-make-tag-str tag nil '(name))
+   'annotation (my/citre-backend--annotation tag)
+   'signature (or (citre-get-tag-field 'signature tag)
+                  (when-let* ((str (citre-get-tag-field 'extra-matched-str tag))) (string-trim str)))
+   'kind (when-let* ((kind (citre-get-tag-field 'ext-kind-full tag))) (intern kind))
+   'tags (citre-get-tag-field 'my-tags tag)))
+
+(defun my/citre-backend--make-collection (tags start end)
+  "Return a completion-at-point value for TAGS between START and END."
+  (when-let* ((candidates (mapcar #'my/citre-backend--make-candidate tags)))
+    (let ((collection (lambda (string predicate action)
+                        (if (eq action 'metadata)
+                            '(metadata (category . citre-completion)
+                                       (cycle-sort-function . identity)
+                                       (display-sort-function . identity))
+                          (complete-with-action action candidates string predicate)))))
+      (list start end collection
+            :annotation-function (lambda (candidate) (citre-get-property 'annotation candidate))
+            :company-docsig (lambda (candidate) (citre-get-property 'signature candidate))
+            :company-kind (lambda (candidate) (citre-get-property 'kind candidate))
+            :exclusive 'no))))
+
 (defun my/citre-backend-completions ()
   "Return current Citre completion bounds and tags, reusing a narrowing prefix."
   (when-let* ((source (car (my/citre-backend--sources)))
-              (symbol (citre-tags-get-symbol (car source)))
+              (symbol (citre-tags-get-symbol (plist-get source :file)))
               (bounds (citre-get-property 'bounds symbol)))
     (let* ((revision (and my/citre-index--state (my/citre-index-state-revision my/citre-index--state)))
+           (member-context (my/citre-backend--member-context (car bounds)))
            (context (list revision (car bounds) major-mode citre-tags-substr-completion
-                          (buffer-substring-no-properties (line-beginning-position) (car bounds))))
+                          (buffer-substring-no-properties (line-beginning-position) (car bounds))
+                          member-context))
+           (tick (buffer-chars-modified-tick))
            (cache my/citre-backend--completion-cache)
            (tags (if (and revision (equal context (plist-get cache :context))
                           (string-prefix-p (plist-get cache :prefix) symbol))
-                     (plist-get cache :tags)
-                   (let ((tags (my/citre-backend--query 'completion)))
+                     (progn (plist-put cache :tick tick) (plist-get cache :tags))
+                   (let ((tags (my/citre-backend--prepare-completions
+                                (my/citre-backend--query 'completion) member-context)))
                      (setq my/citre-backend--completion-cache
-                           (list :context context :prefix (substring-no-properties symbol) :tags tags))
+                           (list :context context :prefix (substring-no-properties symbol)
+                                 :tick tick :tags tags))
                      tags))))
       (when tags (list (car bounds) (cdr bounds) tags)))))
 
+(defun my/citre-completion-at-point ()
+  "Complete with ranked, deduplicated Citre candidates."
+  (when-let* ((result (if citre-capf-optimize-for-popup
+                          (pcase (while-no-input (citre-get-completions)) ('t nil) (value value))
+                        (citre-get-completions)))
+              (beginning (nth 0 result))
+              (end (nth 1 result))
+              (tags (nth 2 result)))
+    (if citre-capf-optimize-for-popup
+        (pcase (while-no-input (my/citre-backend--make-collection tags beginning end))
+          ('t nil) (value value))
+      (my/citre-backend--make-collection tags beginning end))))
+
 (defun my/citre-backend-definitions ()
   "Find definitions in the current live and persistent indexes."
   (my/citre-backend--query 'definition))