diff options
Diffstat (limited to 'elisp')
| -rw-r--r-- | elisp/geiser-autodoc.el | 87 | ||||
| -rw-r--r-- | elisp/geiser-syntax.el | 90 |
2 files changed, 76 insertions, 101 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: |