radium-proto.el

;;; radium-proto.el, gnu-global-backed "autofill from prototype" -*- lexical-binding: t; -*-
;;
;; the advanced-completion piece that would otherwise need an lsp:
;; complete a function name and its whole parameter list gets filled
;; in as yasnippet tab-stops, pre-seeded with the real parameter names
;; pulled from gnu global's tags database (`C-c t g` builds it). the
;; call form matches the language at point: positional calls in c/ada
;; (`foo(a, b)` - legal in both), `(foo a b)` in scheme, plain `foo()`
;; in perl. ada's `Name : Type` params, c's trailing names and scheme's
;; `(define (name args...))` forms all parse for names.
;; `yas-expand-snippet` is autoloaded by package.el once yasnippet is
;; installed, so this doesn't need to load after radium-yasnippet.el.
 
(require 'cl-lib)
 
(defun radium-global-signature (name)
  "the raw source line where NAME is tagged by gnu global, or nil."
  (when (executable-find "global")
    (let ((out (shell-command-to-string
                (format "global -x %s 2>/dev/null" (shell-quote-argument name)))))
      (when (string-match "^\\S-+[ \t]+[0-9]+[ \t]+\\S-+[ \t]+\\(.*\\)$" out)
        (match-string 1 out)))))
 
(defun radium-extract-params (sig)
  "parameter names i pull out of a prototype line SIG, or nil for none:
c's trailing-name style (int a, char* b), ada's name : type style
(a : Integer; b : access T) and scheme's (define (name args...)) all
come out right."
  (when sig
    (cond
     ;; scheme: (define (name arg1 arg2 ...) - a dotted rest-arg
     ;; (define (name x . rest)) splits into ("x" "." "rest") on
     ;; whitespace alone, so the dot itself has to be dropped: it's
     ;; scheme's rest-arg separator, never a real parameter name.
     ((string-match "(define[ \t]+([^()[:space:]]+[ \t]+\\([^()]*\\))" sig)
      (seq-remove (lambda (s) (string= s "."))
                  (split-string (match-string 1 sig) "[ \t]+" t)))
     ;; any other define form - (define (name)), (define name ...),
     ;; (define-syntax ...) - has no args i can use, and i must not let
     ;; it fall through to the c path, whose flat-paren regex garbles
     ;; nested scheme parens.
     ((string-match-p "^(define[- \t]" sig)
      nil)
     (t
      (when (string-match "(\\(.*\\))" sig)
        (let ((inside (string-trim (match-string 1 sig))))
          (unless (or (string= inside "") (string= inside "void"))
            (mapcar
             (lambda (arg)
               (setq arg (string-trim arg))
               (cond
                ;; ada: Name : Type
                ((string-match "\\`\\([A-Za-z_][A-Za-z0-9_]*\\)[ \t]*:" arg)
                 (match-string 1 arg))
                ;; c: Type name
                ((string-match "\\([A-Za-z_][A-Za-z0-9_]*\\)\\'" arg)
                 (match-string 1 arg))
                (t arg)))
             (split-string inside "[;,]")))))))))
 
(defun radium-insert-call-for-name (name &optional replace-preceding)
  "i insert a full call for NAME with one yasnippet tab-stop per
parameter, pre-filled with the real parameter names from gnu global -
positional NAME(a, b) in c/ada, (name a b) in scheme, NAME() in perl.
i fall back to a bare call, or just NAME, if no prototype is found.
 
REPLACE-PRECEDING means NAME was just inserted literally right before
point (e.g. by a completion UI) and i should delete it first."
  (interactive (list (or (thing-at-point 'symbol t) (read-string "function: "))))
  (when replace-preceding
    (let ((len (length name)))
      (when (and (>= (point) (+ (point-min) len))
                 (string= name (buffer-substring-no-properties (- (point) len) (point))))
        (delete-region (- (point) len) (point)))))
  (let* ((sig (radium-global-signature name))
         (params (radium-extract-params sig)))
    (cond
     ;; scheme call form: (name arg1 arg2)
     ((derived-mode-p 'scheme-mode)
      (if params
          (yas-expand-snippet
           (format "(%s %s)" name
                   (string-join
                    (cl-loop for p in params for i from 1
                             collect (format "${%d:%s}" i p))
                    " ")))
        (insert (format "(%s)" name))))
     (params
      (yas-expand-snippet
       (format "%s(%s)" name
               (string-join
                (cl-loop for p in params for i from 1
                         collect (format "${%d:%s}" i p))
                ", "))))
     (sig (insert (format "%s()" name)))
     (t (insert name)))))
 
(defun radium-proto-completion-at-point ()
  "completion-at-point backed by `global -c`, whose candidates i
auto-fill with their parameter list via `radium-insert-call-for-name'
as soon as completion finishes. i decline (return nil) when the tags
db has nothing to offer, so every other backend - geiser, ggtags,
cape - still gets its turn."
  (when (executable-find "global")
    (let* ((bounds (bounds-of-thing-at-point 'symbol))
           (start (car bounds))
           (end (cdr bounds))
           (prefix (and bounds (buffer-substring-no-properties start end))))
      (when (and prefix (>= (length prefix) 2))
        (let ((cands (split-string
                      (shell-command-to-string
                       (format "global -c %s 2>/dev/null"
                               (shell-quote-argument prefix)))
                      "\n" t)))
          (when cands
            (list start end cands
                  :exclusive 'no
                  :exit-function
                  (lambda (completed-name status)
                    (when (memq status '(finished sole))
                      (radium-insert-call-for-name completed-name t))))))))))
 
(dolist (hook '(c-mode-hook ada-mode-hook cperl-mode-hook scheme-mode-hook))
  (add-hook hook
            (lambda ()
              (add-hook 'completion-at-point-functions
                        #'radium-proto-completion-at-point nil t))))
 
(global-set-key (kbd "C-c c c") #'radium-insert-call-for-name)
 
(provide 'radium-proto)