branch: elpa/geiser-stklos
commit 5ab06e9a6b43a67b5885c91f6c2660984743680a
Author: Jeronimo Pellegrini <j...@aleph0.info>
Commit: Jeronimo Pellegrini <j...@aleph0.info>
Add autodoc and symbol documentation support
And some tests!
---
geiser-stklos-test.stk | 52 +++++++++++++++++
geiser-stklos.el | 2 +-
geiser.stk | 149 +++++++++++++++++++++++++++++++++++++++++++------
3 files changed, 186 insertions(+), 17 deletions(-)
diff --git a/geiser-stklos-test.stk b/geiser-stklos-test.stk
index c8c16a4..e66062c 100644
--- a/geiser-stklos-test.stk
+++ b/geiser-stklos-test.stk
@@ -1,6 +1,7 @@
(load "./test.stk")
(load "./geiser.stk")
+(import GEISER)
(test-init "TEST.LOG")
@@ -88,6 +89,57 @@
(values)
(geiser:no-values))
+
+((in-module STKLOS-COMPILER compiler:generate-signature) #t)
+
+(define (f a b . c) "doc for f" a)
+
+(test "geiser:symbol-documentation"
+ '(("signature" f ("args" (("required" a b)
+ ("optional" "...")
+ ("key"))))
+ ("docstring" . "A procedure in module stklos.\ndoc for f"))
+ (geiser:symbol-documentation 'f))
+
+
+
+(test-subsection "internal procedures")
+
+(select-module GEISER)
+
+(test "bound? no"
+ #f
+ (bound? (gensym) (current-module)))
+
+(define a -1)
+(test "bound? yes"
+ #t
+ (bound? 'a (current-module)))
+
+(define x (list-copy '(a b . c)))
+(define y (list-copy '(a b c)))
+(test "nullify-last-cdr! improper"
+ '(a b)
+ (begin
+ (nullify-last-cdr! x)
+ x))
+
+(test "nullify-last-cdr! improper"
+ '(a b c)
+ (begin
+ (nullify-last-cdr! y)
+ y))
+
+(define (f a b . c) "doc for f" a)
+(test "geiser:procedure-signature"
+ '(f ("args" (("required" a b)
+ ("optional" "...")
+ ("key")))
+ ("module" stklos))
+ ((in-module GEISER geiser:procedure-signature) 'f 'stklos))
+
+(select-module stklos)
+
(test-section-end)
(test-end)
diff --git a/geiser-stklos.el b/geiser-stklos.el
index 5d62080..959d49f 100644
--- a/geiser-stklos.el
+++ b/geiser-stklos.el
@@ -300,7 +300,7 @@ This function uses `geiser-stklos-init-file' if it exists."
(check-buffer geiser-stklos--guess)
(keywords geiser-stklos--keywords) ; ok
(case-sensitive geiser-stklos-case-sensitive) ; ok
- (unsupported '(autodoc callers callees)) ; doesn't seem to
make any difference?
+ (unsupported '(callers callees)) ; doesn't seem to
make any difference?
)
;; STklos files are .stk, and we may wat to open .scm files with STklos also:
diff --git a/geiser.stk b/geiser.stk
index 9746388..f1ec616 100644
--- a/geiser.stk
+++ b/geiser.stk
@@ -78,12 +78,14 @@
(newline)))
-;; to log forms, use the following:
+;; to log forms, uncomment the following line and the
+;; lines that were commented out in the write-to-log
+;; procedure below:
;; (define log (open-output-file "geiser-log.txt"))
(define (write-to-log form)
;; (write form log)
-;; (newline log))
+;; (newline log)
(values))
;; evaluates form inside a module.
@@ -217,21 +219,136 @@
(else '())))
-;; returns the documentation for a symbol
-(define (geiser:symbol-documentation name)
- (with-output-to-string
- (lambda () (help (eval (eval name))))))
-
-;; used for autodoc. returns the documentation for a symbol.
+;; formats the signature of a procedure in the format required by Geiser.
+;;
+;; (define (f a b . c) a)
+;; (geiser:procedure-signature 'f 'stklos)
+;; => (f ("args" (("required" a b)
+;; ("optional" "...")
+;; ("key")))
+;; ("module" stklos))
+;;
+(define (geiser:procedure-signature name mod-name)
+ (let ((sig (list-copy (%procedure-signature (eval name (find-module
mod-name))))))
+ (if sig
+ (let ((proper (list? sig)))
+ (let ((optional-args (if proper '() '("..."))))
+ (when (not proper) (nullify-last-cdr! sig))
+ `(,name ("args" (("required" ,@sig)
+ ("optional" ,@optional-args)
+ ("key")))
+ ("module" ,mod-name))))
+ ""))) ;; if there's no signature, don't show anything
+
+
+;; returns the documentation for a symbol, which includes
+;; the docstring for a procedure, and the value for variables.
+;;
+;; (define (f a b . c) "the documentation for f..." a)
+;; (geiser:symbol-documentation 'f 'stklos)
+;; => (("signature" f ("args" (("required" a b)
+;; ("optional" "...")
+;; ("key"))))
+;; ("docstring" . "A procedure in module GEISER.\nthe documentation for
f..."))
+;;
+;; (define x #(10 20 30))
+;; (geiser:symbol-documentation 'x 'stklos)
+;; => (("signature" x ("args"))
+;; ("docstring" . "An object in module GEISER.\n\nValue:\n #(10 20 30)"))
+;;
+(define (geiser:symbol-documentation name . rest)
+ (let ((mod-name (if (null? rest)
+ (module-name (current-module))
+ (car rest))))
+ (cond ((procedure? (eval name (find-module mod-name)))
+ (let ((sig (geiser:procedure-signature name mod-name))
+ (doc (%procedure-doc (eval name (find-module mod-name)))))
+ (let ((res
+ `(("signature" ,name ,(assoc "args" (cdr sig)))
+ ("docstring" . ,(string-append "A procedure in module "
+ (symbol->string mod-name) ".\n"
+ (if doc doc ""))))))
+ (write-to-log res)
+ res)))
+ ((bound? name mod-name) ; variable
+ `(("signature" ,name ("args"))
+ ("docstring" . ,(string-append "An object in module "
+ (symbol->string mod-name)
+ ".\n\nValue:\n "
+ (with-output-to-string
+ (lambda () (eval `(write ,name)
+ (find-module
mod-name))))))))
+ (else ""))))
+
+;; predicate - returns #t if id is bound in module.
+(define (bound? id module)
+ (cond ((string? module)
+ (bound? id (find-module (string->symbol module))))
+ ((symbol? module)
+ (let ((flag (gensym "it-is-unbound")))
+ (not (eq? (symbol-value id (find-module module) flag)
+ flag))))
+ ((module? module)
+ (bound? id (module-name module)))
+ (else #f))) ;; really?
+
+
+;; nullify-last-cdr! turns improper lists into proper lists by removing
+;; the last element and putting '() in its place.
+;;
+;; *** The lists MUST BE MUTABLE! (hence the user of
+;; "list-copy" in the examples below ***
+;;
+;; (define a (list-copy '(1 2 . 3)))
+;; (define b (list-copy '(1 2 3)))
+;; (nullify-last-cdr! a)
+;; (nullify-last-cdr! b)
+;; a => (1 2)
+;; b => (1 2 3)
+(define (nullify-last-cdr! lst)
+ (cond ((not (or (list? lst)
+ (pair? lst)))
+ (error 'set-last-cdr! "Not a cons cell: ~S" lst))
+ ((pair? (cdr lst))
+ (nullify-last-cdr! (cdr lst)))
+ (else
+ (set-cdr! lst '()))))
+
+(define (geiser-build-autodoc name module)
+ (let ((mod-name (cond ((string? module) (string->symbol module))
+ ((module? module) (module-name module))
+ ((symbol? module) module))))
+ (cond ((not (bound? name mod-name))
+ "")
+ ((procedure? (eval name (find-module mod-name)))
+ (geiser:procedure-signature name mod-name))
+ (else ;; it's a variable?
+ `(,name ("value" . ,(eval name (find-module mod-name)))
+ ("module" ,mod-name))))))
+
+;; autodoc receives a list of names, and possibly a module name.
+;; it returns a list of documentations for each name:
+;;
+;; (define (f a c) a)
+;; (define (g a b :optional (c 1))
+;; (define a #(1 2 3))
+;;
+;; (geiser:autodoc '(f g a))
+;; =>
+;; ((f ("args" (("required" a c) ("optional") ("key"))) ("module"
stklos))
+;; (g ("args" (("required" . #void) ("optional" "...") ("key"))) ("module"
stklos))
+;; (a ("value" . #(1 2 3)) ("module" stklos)))
+;;
(define (geiser:autodoc names . rest)
- #f)
-;; (cond ((null? names) '())
-;; ((not (list? names))
-;; (geiser:autodoc (list names)))
-;; ((symbol? (car names))
-;; (with-output-to-string
-;; (lambda () (help (car names)))))
-;; (else "")))
+ (cond ((null? names) '())
+ ((symbol? names)
+ (geiser:autodoc (list names)))
+ ((list? names)
+ (let ((module (if (null? rest)
+ (current-module)
+ (car rest))))
+ (map (lambda (n) (geiser-build-autodoc n module)) names)))
+ (else "")))
;; The no-values identity
(define (geiser:no-values)
