diff options
| -rw-r--r-- | elisp/geiser-autodoc.el | 87 | ||||
| -rw-r--r-- | elisp/geiser-syntax.el | 90 | ||||
| -rw-r--r-- | scheme/guile/geiser/emacs.scm | 2 | ||||
| -rw-r--r-- | scheme/guile/geiser/introspection.scm | 118 |
4 files changed, 136 insertions, 161 deletions
diff --git a/elisp/geiser-autodoc.el b/elisp/geiser-autodoc.el index 7460aa1..9f5954d 100644 --- a/elisp/geiser-autodoc.el +++ b/elisp/geiser-autodoc.el @@ -67,64 +67,65 @@ when `geiser-autodoc-display-module-p' is on." (make-variable-buffer-local (defvar geiser-autodoc--last-funs nil)) -(defun geiser-autodoc--function-args (funs) - (when funs - (let ((pr (and (eq (car geiser-autodoc--last) (caar funs)) (car funs)))) - (if pr (geiser-autodoc--fun-args-str (car pr) - (cdr geiser-autodoc--last) - (cdr pr)) - (setq geiser-autodoc--last-funs funs) - (geiser-eval--send - `(:eval ((:ge arguments) ,@(mapcar (lambda (f) (list 'quote (car f))) funs))) - 'geiser-autodoc--function-args-cont) - "")))) - -(defun geiser-autodoc--function-args-cont (ret) - (let ((result (geiser-eval--retort-result ret))) - (when (and result (listp result)) - (setq geiser-autodoc--last result) - (let* ((pos (or (cdr (assoc (car result) geiser-autodoc--last-funs)) 0)) - (msg (geiser-autodoc--fun-args-str (car result) (cdr result) pos))) - (when msg (eldoc-message msg)))))) - -(defun geiser-autodoc--insert (sym current pos) - (let ((str (format "%s" sym))) +(defun geiser-autodoc--function-args (form) + (if (equal (car geiser-autodoc--last) form) (cdr geiser-autodoc--last) + (when form + (let ((res (geiser-eval--send/result + `(:eval ((:ge autodoc) (quote (:scm ,form))))))) + (when (and res (listp res)) + (setq geiser-autodoc--last + (cons form + (geiser-autodoc--str (cdr (assoc 'signature res)) + (or (cdr (assoc 'position res)) 0) + (cdr (assoc 'module res))))) + (cdr geiser-autodoc--last)))))) + +(defun geiser-autodoc--insert-arg (arg current pos) + (let ((str (format "%s" arg))) (when (= current pos) (put-text-property 0 (length str) 'face 'geiser-font-lock-autodoc-current-arg str)) (insert str))) -(defun geiser-autodoc--fun-args-str (fun args pos) - (when fun +(defun geiser-autodoc--insert-args (arg args current pos) + (when arg + (geiser-autodoc--insert-arg arg current pos) + (cond ((null args) (insert ")")) + ((listp args) + (insert " ") + (geiser-autodoc--insert-args (car args) (cdr args) (1+ current) pos)) + (t (insert " . ") + (geiser-autodoc--insert-args args nil (1+ current) pos))))) + +(defun geiser-autodoc--str (signature pos module) + (when signature (save-current-buffer (set-buffer (geiser-syntax--font-lock-buffer)) (erase-buffer) - (let* ((current 0) - (module (and geiser-autodoc-display-module-p - (cdr (assoc 'module args)))) - (fun (if module - (format geiser-autodoc-procedure-name-format module fun) - fun))) - (insert "(") - (geiser-autodoc--insert fun current pos) - (dolist (arg (cdr (assoc 'required args))) - (setq current (1+ current)) - (insert " ") - (geiser-autodoc--insert arg current pos)) - (setq current (1+ current)) - (when (cdr (assoc 'optional args)) - (when (> pos current) (setq current pos)) - (insert " . ") - (geiser-autodoc--insert (cdr (assoc 'optional args)) current pos)) - (insert ")") + (let ((proc (car signature)) + (args (cdr signature))) + (insert (format "(%s " + (if module + (format geiser-autodoc-procedure-name-format module proc) + proc))) + (if args + (if (listp args) + (geiser-autodoc--insert-args (car args) (cdr args) 1 pos) + (insert ". ") + (geiser-autodoc--insert-arg args 1 1) + (insert ")")) + (delete-char -1) + (insert ")")) (buffer-string))))) ;;; Autodoc function: (defun geiser-autodoc--eldoc-function () - (or (geiser-autodoc--function-args (geiser-syntax--enclosing-form-data)) "")) + (condition-case e + (or (geiser-autodoc--function-args (geiser-syntax--get-partial-sexp t)) "") + (error (format "Autodoc not available (%s)" (error-message-string e))))) ;;; Autodoc mode: diff --git a/elisp/geiser-syntax.el b/elisp/geiser-syntax.el index 2025f3d..c8ad338 100644 --- a/elisp/geiser-syntax.el +++ b/elisp/geiser-syntax.el @@ -55,27 +55,47 @@ (geiser-popup--define syntax " *geiser syntax analyst*" scheme-mode) -(defun geiser-syntax--complete-partial-sexp (buffer begin end) +(defun geiser-syntax--prepare-scheme-for-elisp-reader () + (goto-char (point-min)) + (while (re-search-forward "#\<\\([^>]*?\\)\>" nil t) + (let ((from (match-beginning 1)) + (to (match-end 1))) + (goto-char from) + (while (re-search-forward "\\([() ;'`]\\)" to t) + (replace-match "\\\\\\1")) + (goto-char to))) + (goto-char (point-min)) + (while (re-search-forward "#(" nil t) (replace-match "(vector ")) + (goto-char (point-min)) + (while (re-search-forward "#" nil t) (replace-match "\\\\#")) + (goto-char (point-min)) + (skip-syntax-forward "^(")) + +(defun geiser-syntax--complete-partial-sexp (buffer begin end &optional str) (set-buffer buffer) (let ((inhibit-read-only t)) (copy-to-buffer (geiser-syntax--buffer) begin end)) (geiser-syntax--with-buffer (goto-char (point-max)) - (skip-syntax-backward "-") + (skip-syntax-backward "-<>") + (kill-region (point) (point-max)) (let ((pps (parse-partial-sexp (point-min) (point)))) - (cond ((nth 8 pps) ;; inside a comment or string - (delete-region (nth 8 pps) (point-max))) - ((nth 5 pps) (delete-char -1))) ;; after a quote - (let ((depth (nth 0 pps))) - (unless (zerop depth) (insert (make-string depth ?\))))) + (when (nth 8 pps) ;; inside a comment or string + (delete-region (nth 8 pps) (point-max)))) + (cond ((eq (char-after (1- (point))) ?\)) (kill-sexp -1) (insert "XXpointXX")) + ((eq (char-after (point)) ?\() (kill-sexp 1) (insert "XXpointXX"))) + (let ((depth (nth 0 (parse-partial-sexp (point-min) (point))))) + (unless (zerop depth) (insert (make-string depth ?\))))) + (if str + (buffer-string) (geiser-syntax--prepare-scheme-for-elisp-reader) (read (current-buffer))))) -(defsubst geiser-syntax--get-partial-sexp () - (save-excursion - (let* ((begin (point)) - (end (progn (beginning-of-defun) (point)))) - (geiser-syntax--complete-partial-sexp (current-buffer) begin end)))) +(defsubst geiser-syntax--get-partial-sexp (&optional str) + (unless (zerop (nth 0 (syntax-ppss))) + (let* ((end (save-excursion (skip-syntax-forward "^-()") (point))) + (begin (save-excursion (beginning-of-defun) (point)))) + (geiser-syntax--complete-partial-sexp (current-buffer) begin end str)))) (defun geiser-syntax--collect-local-symbols (sexp acc) (cond ((or (null sexp) (not (listp sexp))) acc) @@ -100,52 +120,6 @@ (mapcar 'symbol-name (geiser-syntax--collect-local-symbols (geiser-syntax--get-partial-sexp) '())))) -(defsubst geiser-syntax--end-of-thing () - (let ((sc (or (syntax-class (syntax-after (point))) 0))) - (when (= sc 7) (forward-char)) - (cond ((nth 3 (syntax-ppss)) - (skip-syntax-forward "^\"") - (forward-char)) - ((and (= sc 5) (eq ?\( (char-before))) (forward-char)) - ((not (or (= sc 0) (= sc 12))) ;; comment, whitespace - (ignore-errors (forward-sexp)))) - (point))) - -(defun geiser-syntax--enclosing-form-data () - (save-excursion - (let* ((p (geiser-syntax--end-of-thing)) - (current (cons (symbol-at-point) 0)) - (data)) - (ignore-errors - (while (not (bobp)) - (backward-up-list) - (save-excursion - (forward-char) - (let ((proc (symbol-at-point)) - (arg-no 0)) - (when proc - (while (< (point) p) - (forward-sexp) - (when (< (point) p) (setq arg-no (1+ arg-no)))) - (push (cons proc arg-no) data)))))) - (reverse (if (car current) (push current data) data))))) - -(defun geiser-syntax--prepare-scheme-for-elisp-reader () - (goto-char (point-min)) - (while (re-search-forward "#\<\\([^>]*?\\)\>" nil t) - (let ((from (match-beginning 1)) - (to (match-end 1))) - (goto-char from) - (while (re-search-forward "\\([() ;'`]\\)" to t) - (replace-match "\\\\\\1")) - (goto-char to))) - (goto-char (point-min)) - (while (re-search-forward "#(" nil t) (replace-match "(vector ")) - (goto-char (point-min)) - (while (re-search-forward "#" nil t) (replace-match "\\\\#")) - (goto-char (point-min)) - (skip-syntax-forward "^(")) - ;;; Fontify strings as Scheme code: diff --git a/scheme/guile/geiser/emacs.scm b/scheme/guile/geiser/emacs.scm index f440827..7f03be8 100644 --- a/scheme/guile/geiser/emacs.scm +++ b/scheme/guile/geiser/emacs.scm @@ -29,7 +29,7 @@ ge:compile ge:compile-file ge:load-file) - #:re-export (ge:arguments + #:re-export (ge:autodoc ge:completions ge:symbol-location ge:symbol-documentation diff --git a/scheme/guile/geiser/introspection.scm b/scheme/guile/geiser/introspection.scm index ca6afae..4b833d5 100644 --- a/scheme/guile/geiser/introspection.scm +++ b/scheme/guile/geiser/introspection.scm @@ -25,7 +25,7 @@ ;;; Code: (define-module (geiser introspection) - #:export (arguments + #:export (autodoc completions symbol-location symbol-documentation @@ -33,23 +33,63 @@ module-children module-location) #:use-module (system vm program) + #:use-module (ice-9 regex) #:use-module (ice-9 session) #:use-module (ice-9 documentation) #:use-module (srfi srfi-1)) -(define (arguments sym . syms) - (let loop ((sym sym) (syms syms)) - (cond ((obj-args (symbol->obj sym)) => (lambda (args) - (cons sym (apply args-alist args)))) - ((null? syms) #f) - (else (loop (car syms) (cdr syms)))))) +(define (autodoc form) + (cond ((null? form) #f) + ((symbol? form) (describe-application (list form))) + ((list? form) + (let ((lst (last form))) + (cond ((symbol? lst) (or (describe-application (list lst)) + (describe-application form))) + ((list? lst) + (or (autodoc lst) + (autodoc (map (lambda (s) (if (list? s) (gensym) s)) form)))) + (else (describe-application form))))) + (else #f))) -(define (args-alist args opt module) - (list (cons 'required args) - (cons 'optional (or opt '())) - (cons 'module (cond ((module? module) (module-name module)) - ((list? module) module) - (else '()))))) +(define (describe-application form) + (let* ((fun (car form)) + (args (obj-args (symbol->obj fun)))) + (and args + (list (cons 'signature (signature fun args)) + (cons 'position (find-position args form)) + (cons 'module (symbol-module fun)))))) + +(define (signature fun args) + (let ((req (assq-ref args 'required)) + (opt (assq-ref args 'optional)) + (key (assq-ref args 'keyword)) + (rest (assq-ref args 'rest))) + (let ((sgn `(,fun ,@(or req '()) + ,@(if opt (cons #:optional opt) '()) + ,@(if key (cons #:key key) '())))) + (if rest `(,@sgn . ,rest) sgn)))) + +(define (find-position args form) + (let* ((lf (length form)) + (lf-1 (- lf 1))) + (if (= 1 lf) 0 + (let ((req (length (or (assq-ref args 'required) '()))) + (opt (length (or (assq-ref args 'optional) '()))) + (keys (map (lambda (k) (symbol->keyword (if (list? k) (car k) k))) + (or (assq-ref args 'keyword) '()))) + (rest (assq-ref args 'rest))) + (cond ((<= lf (+ 1 req)) lf-1) + ((<= lf (+ 1 req opt)) (if (> opt 0) lf lf-1)) + ((or (memq (last form) keys) + (memq (car (take-right form 2)) keys)) => + (lambda (sl) + (+ 2 req + (if (> opt 0) (+ 1 opt) 0) + (- (length keys) (length sl))))) + (else (+ 1 req + (if (> opt 0) (+ 1 opt) 0) + (if (null? keys) 0 (+ 1 (length keys))) + (if rest 1 0)))))))) (define (symbol->obj sym) (and (symbol? sym) @@ -58,9 +98,9 @@ (define (obj-args obj) (cond ((not obj) #f) - ((program? obj) (program-args obj)) - ((procedure? obj) (procedure-args obj)) - ((macro? obj) (macro-args obj)) + ((or (procedure? obj) (program? obj)) (procedure-arguments obj)) + ((macro? obj) (or (obj-args (macro-transformer obj)) + '((required ...)))) (else #f))) (define (symbol-module sym) @@ -70,47 +110,9 @@ (apropos-fold (lambda (module name var init) (if (eq? name sym) (k (module-name module)) init)) #f - (symbol->string sym) + (regexp-quote (symbol->string sym)) (apropos-fold-accessible (current-module))))))) -(define (program-args program) - (let* ((arity (program-arity program)) - (arg-no (first arity)) - (opt (> (second arity) 0)) - (args (map first (take (program-bindings program) arg-no)))) - (list (if opt (drop-right args 1) args) - (and opt (last args)) - (program-module program)))) - -(define (procedure-args proc) - (let ((name (procedure-name proc))) - (cond ((procedure-source proc) => (lambda (src) - (procedure-args-from-source name src))) - (else (let* ((arity (procedure-property proc 'arity)) - (req (first arity)) - (opt (third arity))) - (list (map (lambda (n) - (string->symbol (format "arg~A" (+ 1 n)))) - (iota req)) - (and opt 'rest) - (and name (symbol-module name)))))))) - -(define (procedure-args-from-source name src) - (let ((formals (cadr src))) - (cond ((list? formals) (list formals #f (symbol-module name))) - ((pair? formals) (let ((req (car formals)) - (opt (cdr formals))) - (list (if (list? req) req (list req)) - opt - (symbol-module name)))) - (else #f)))) - -(define (macro-args macro) - (let ((prog (macro-transformer macro))) - (if prog - (obj-args prog) - (list '(...) #f #f)))) - (define (completions prefix) (sort! (map symbol->string (apropos-internal (string-append "^" prefix))) @@ -147,10 +149,8 @@ (if doc (display doc)))))) (define (obj-signature sym obj) - (let* ((args (obj-args obj)) - (req (and args (car args))) - (opt (and args (cadr args)))) - (and args (if (not opt) `(,sym ,@req) `(,sym ,@req . ,opt))))) + (let ((args (obj-args obj))) + (and args (signature sym args)))) (define (symbol-documentation sym) (let ((obj (symbol->obj sym))) |