summaryrefslogtreecommitdiff
path: root/elisp
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2009-02-27 23:29:09 +0100
committerJose Antonio Ortega Ruiz <jao@gnu.org>2009-02-27 23:29:09 +0100
commit3d0d1ce42229a8e6cd62d1a1c8f9b1c4c104293a (patch)
tree2e542cfc37c0ae7e6527ffee5faeccb5ec6d4589 /elisp
parent8337756109d12349b220ba422f148555a2d031c2 (diff)
downloadgeiser-chez-3d0d1ce42229a8e6cd62d1a1c8f9b1c4c104293a.tar.gz
geiser-chez-3d0d1ce42229a8e6cd62d1a1c8f9b1c4c104293a.tar.bz2
Autodoc system revamped.
Diffstat (limited to 'elisp')
-rw-r--r--elisp/geiser-autodoc.el87
-rw-r--r--elisp/geiser-syntax.el90
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: