From 3d0d1ce42229a8e6cd62d1a1c8f9b1c4c104293a Mon Sep 17 00:00:00 2001
From: Jose Antonio Ortega Ruiz <jao@gnu.org>
Date: Fri, 27 Feb 2009 23:29:09 +0100
Subject: Autodoc system revamped.

---
 elisp/geiser-autodoc.el               |  87 ++++++++++++-------------
 elisp/geiser-syntax.el                |  90 +++++++++-----------------
 scheme/guile/geiser/emacs.scm         |   2 +-
 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)))
-- 
cgit v1.2.3