summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2010-11-21 01:56:02 +0100
committerJose Antonio Ortega Ruiz <jao@gnu.org>2010-11-21 01:56:02 +0100
commit1d725a8c087b66b2cd2c0e5006c376faf612d6ff (patch)
treee660e30075c5b03b64da49988683af048eb4f6b0
parent481f0ea2e5577ad5bb1a718b8023af92202e7423 (diff)
downloadgeiser-chez-1d725a8c087b66b2cd2c0e5006c376faf612d6ff.tar.gz
geiser-chez-1d725a8c087b66b2cd2c0e5006c376faf612d6ff.tar.bz2
Better module help
We now display procedure signatures in module help, and keep a cache in Guile, using procedure properties.
-rw-r--r--doc/img/repl-mod.pngbin17604 -> 29938 bytes
-rw-r--r--elisp/geiser-doc.el32
-rw-r--r--scheme/guile/geiser/doc.scm62
-rw-r--r--scheme/guile/geiser/modules.scm34
-rw-r--r--scheme/guile/geiser/utils.scm8
-rw-r--r--scheme/racket/geiser/autodoc.rkt66
-rw-r--r--scheme/racket/geiser/eval.rkt12
-rw-r--r--scheme/racket/geiser/main.rkt16
-rw-r--r--scheme/racket/geiser/modules.rkt35
9 files changed, 149 insertions, 116 deletions
diff --git a/doc/img/repl-mod.png b/doc/img/repl-mod.png
index a2dcb10..9814b7e 100644
--- a/doc/img/repl-mod.png
+++ b/doc/img/repl-mod.png
Binary files differ
diff --git a/elisp/geiser-doc.el b/elisp/geiser-doc.el
index 7d42ce5..b95242c 100644
--- a/elisp/geiser-doc.el
+++ b/elisp/geiser-doc.el
@@ -122,19 +122,22 @@
(define-button-type 'geiser-doc--button
'action 'geiser-doc--button-action
- 'face 'geiser-font-lock-doc-link
'follow-link t)
-(defun geiser-doc--insert-button (target module impl)
+(defun geiser-doc--insert-button (target module impl &optional sign)
(let ((link (geiser-doc--make-link target module impl))
- (text (format "%s" (or target module)))
+ (text (format "%s" (or (and sign (geiser-autodoc--str* sign))
+ target
+ module)))
(help (format "%smodule %s"
(if target (format "%s in " target) "")
(or module "<unknown>"))))
- (insert-text-button text
- :type 'geiser-doc--button
- 'geiser-link link
- 'help-echo help)))
+ (apply 'insert-text-button
+ `(,text
+ :type geiser-doc--button
+ ,@(and (not sign) (list 'face 'geiser-font-lock-doc-link))
+ geiser-link ,link
+ help-echo ,help))))
(defun geiser-doc--xbutton-action (button)
(when geiser-doc--buffer-link
@@ -183,7 +186,7 @@
(insert (format "%s" title))
(insert "(" (format "%s" (car title)))
(dolist (a (cdr title))
- (insert " " (if (eq a '\#:rest) "." (format "%s" a))))
+ (insert " " (if (eq a :rest) "." (format "%s" a))))
(insert ")"))
(put-text-property p (point) 'face 'geiser-font-lock-doc-title)
(when top
@@ -199,11 +202,12 @@
(geiser-doc--insert-title title)
(newline)
(dolist (w lst)
- (let ((name (if (listp w) (car w) w))
- (info (and (listp w) (cdr w))))
+ (let ((name (car w))
+ (signature (cdr (assoc 'signature w)))
+ (info (cdr (assoc 'info w))))
(insert (format "\t- "))
(if module
- (geiser-doc--insert-button name module impl)
+ (geiser-doc--insert-button name module impl signature)
(geiser-doc--insert-button nil name impl))
(when info (insert (format " %s" info)))
(newline)))
@@ -262,7 +266,10 @@ With prefix argument, ask for symbol (with completion)."
"Display information about a given module."
(interactive)
(let* ((module (or module (geiser-completion--read-module)))
- (exports (geiser-doc--get-module-exports module))
+ (msg (format "Retrieving documentation for %s ..." module))
+ (exports (progn
+ (message "%s" msg)
+ (geiser-doc--get-module-exports module)))
(impl (or impl geiser-impl--implementation)))
(if (not exports)
(message "No information available for %s" module)
@@ -286,6 +293,7 @@ With prefix argument, ask for symbol (with completion)."
(geiser-doc--make-link nil module impl)))
(geiser-doc--insert-footer)
(goto-char (point-min)))
+ (message "%s done" msg)
(geiser-doc--pop-to-buffer))))
(defun geiser-doc-next (&optional forget-current)
diff --git a/scheme/guile/geiser/doc.scm b/scheme/guile/geiser/doc.scm
index 902f2a3..345febd 100644
--- a/scheme/guile/geiser/doc.scm
+++ b/scheme/guile/geiser/doc.scm
@@ -12,6 +12,7 @@
(define-module (geiser doc)
#:export (autodoc
symbol-documentation
+ module-exports
object-signature)
#:use-module (geiser utils)
#:use-module (geiser modules)
@@ -58,9 +59,17 @@
(define default-macro-args '(((required ...))))
+(define geiser-args-key (gensym "geiser-args-key-"))
+
(define (obj-args obj)
(cond ((not obj) #f)
- ((or (procedure? obj) (program? obj)) (arguments obj))
+ ((or (procedure? obj) (program? obj))
+ (cond ((procedure-property obj geiser-args-key))
+ ((arguments obj) =>
+ (lambda (args)
+ (set-procedure-property! obj geiser-args-key args)
+ args))
+ (else #f)))
((and (macro? obj) (macro-transformer obj)) => macro-args)
((macro? obj) default-macro-args)
(else 'variable)))
@@ -121,17 +130,12 @@
(define (doc->args proc)
(define proc-rx "-- Scheme Procedure: ([^[\n]+)\n")
(define proc-rx2 "-- Scheme Procedure: ([^[\n]+\\[[^\n]*(\n[^\n]+\\]+)?)")
- (cond ((procedure-property proc 'geiser-document-args))
- ((object-documentation proc)
- => (lambda (doc)
- (let* ((match (or (string-match proc-rx doc)
- (string-match proc-rx2 doc)))
- (args (and match
- (parse-signature-string
- (match:substring match 1)))))
- (set-procedure-property! proc 'geiser-document-args args)
- args)))
- (else #f)))
+ (let ((doc (object-documentation proc)))
+ (and doc
+ (let ((match (or (string-match proc-rx doc)
+ (string-match proc-rx2 doc))))
+ (and match
+ (parse-signature-string (match:substring match 1)))))))
(define (parse-signature-string str)
(define opt-arg-rx "\\[([^] ]+)\\]?")
@@ -204,4 +208,36 @@
(let ((args (obj-args obj)))
(and args (signature sym args))))
-;;; doc.scm ends here
+(define (module-exports mod-name)
+ (define elt-sort (make-symbol-sort car))
+ (let* ((mod (catch #t
+ (lambda () (resolve-interface mod-name))
+ (lambda args (resolve-module mod-name))))
+ (elts (hash-fold classify-module-object
+ (list '() '() '())
+ (module-obarray mod)))
+ (elts (map elt-sort elts))
+ (subs (map (lambda (m) (list (module-name m)))
+ (submodules (resolve-module mod-name #f)))))
+ (list (cons 'modules subs)
+ (cons 'procs (car elts))
+ (cons 'syntax (cadr elts))
+ (cons 'vars (caddr elts)))))
+
+(define (classify-module-object name var elts)
+ (let ((obj (and (variable-bound? var)
+ (variable-ref var))))
+ (cond ((or (not obj) (module? obj)) elts)
+ ((or (procedure? obj) (program? obj))
+ (list (cons (list name `(signature . ,(obj-signature name obj)))
+ (car elts))
+ (cadr elts)
+ (caddr elts)))
+ ((macro? obj)
+ (list (car elts)
+ (cons (list name `(signature . ,(obj-signature name obj)))
+ (cadr elts))
+ (caddr elts)))
+ (else (list (car elts)
+ (cadr elts)
+ (cons (list name) (caddr elts)))))))
diff --git a/scheme/guile/geiser/modules.scm b/scheme/guile/geiser/modules.scm
index a1697a7..df53acb 100644
--- a/scheme/guile/geiser/modules.scm
+++ b/scheme/guile/geiser/modules.scm
@@ -15,7 +15,7 @@
module-path
find-module
all-modules
- module-exports
+ submodules
module-location)
#:use-module (geiser utils)
#:use-module (system vm program)
@@ -76,35 +76,3 @@
(list mod)
cs)))
-(define (module-exports mod-name)
- (let* ((mod (catch #t
- (lambda () (resolve-interface mod-name))
- (lambda args (resolve-module mod-name))))
- (elts (hash-fold classify-module-object
- (list '() '() '())
- (module-obarray mod)))
- (elts (map sort-symbols! elts))
- (subs (map module-name (submodules (resolve-module mod-name #f)))))
- (list (cons 'modules (append subs
- (map (lambda (m)
- `(,@mod-name ,m)) (car elts))))
- (cons 'procs (cadr elts))
- (cons 'vars (caddr elts)))))
-
-(define (classify-module-object name var elts)
- (let ((obj (and (variable-bound? var)
- (variable-ref var))))
- (cond ((not obj) elts)
- ((and (module? obj) (eq? (module-kind obj) 'directory))
- (list (cons name (car elts))
- (cadr elts)
- (caddr elts)))
- ((or (procedure? obj) (program? obj) (macro? obj))
- (list (car elts)
- (cons name (cadr elts))
- (caddr elts)))
- (else (list (car elts)
- (cadr elts)
- (cons name (caddr elts)))))))
-
-;;; modules.scm ends here
diff --git a/scheme/guile/geiser/utils.scm b/scheme/guile/geiser/utils.scm
index 01dfaa0..632fe76 100644
--- a/scheme/guile/geiser/utils.scm
+++ b/scheme/guile/geiser/utils.scm
@@ -14,6 +14,7 @@
symbol->object
pair->list
sort-symbols!
+ make-symbol-sort
gensym?)
#:use-module (ice-9 regex))
@@ -37,6 +38,13 @@
(string<? (symbol->string l) (symbol->string r)))))
(sort! syms cmp)))
+(define (make-symbol-sort sel)
+ (let ((cmp (lambda (a b)
+ (string<? (symbol->string (sel a))
+ (symbol->string (sel b))))))
+ (lambda (syms)
+ (sort! syms cmp))))
+
(define (gensym? sym)
(and (symbol? sym) (gensym-name? (format "~A" sym))))
diff --git a/scheme/racket/geiser/autodoc.rkt b/scheme/racket/geiser/autodoc.rkt
index ce6553f..e9c6a07 100644
--- a/scheme/racket/geiser/autodoc.rkt
+++ b/scheme/racket/geiser/autodoc.rkt
@@ -11,9 +11,14 @@
#lang racket
-(provide autodoc update-signature-cache get-help)
+(provide autodoc module-exports update-signature-cache get-help)
-(require geiser/utils geiser/modules geiser/locations scheme/help)
+(require racket/help
+ syntax/modcode
+ syntax/modresolve
+ geiser/utils
+ geiser/modules
+ geiser/locations)
(define (get-help symbol mod)
(with-handlers ([exn? (lambda (_)
@@ -25,7 +30,7 @@
'()
(map (lambda (id) (or (autodoc* id) (list id))) ids)))
-(define (autodoc* id)
+(define (autodoc* id (extra #t))
(define (val)
(with-handlers ([exn? (const "")])
(format "~.a" (namespace-variable-value id))))
@@ -34,13 +39,20 @@
(let* ([loc (symbol-location* id)]
[name (car loc)]
[path (cdr loc)]
- [sgns (and path (find-signatures path name id))])
+ [sgns (and path (find-signatures path name id))]
+ [value (if (and extra sgns (not (list? sgns)))
+ (list (cons 'value (val)))
+ '())]
+ [mod (if (and extra sgns path)
+ (list (cons 'module
+ (module-path-name->name path)))
+ '())])
(and sgns
`(,id
(name . ,name)
- (value . ,(if (list? sgns) "" (val)))
(args ,@(if (list? sgns) (map format-signature sgns) '()))
- (module . ,(module-path-name->name path)))))))
+ ,@value
+ ,@mod)))))
(define (format-signature sign)
(if (signature? sign)
@@ -178,12 +190,44 @@
[(list? arity) (map arity->signature arity)]
[else (list (arity->signature arity))]))
-(define (update-signature-cache path . form)
+(define (update-signature-cache path (form #f))
(when (and (string? path)
- (or (null? form)
- (and (list? (car form))
- (not (null? (car form)))
- (memq (caar form)
+ (or (not form)
+ (and (list? form)
+ (not (null? form))
+ (memq (car form)
'(define-syntax-rule struct
define-syntax define set! define-struct)))))
(hash-remove! signatures path)))
+
+(define (module-exports mod)
+ (define (value id)
+ (with-handlers ([exn? (const #f)])
+ (dynamic-require mod id (const #f))))
+ (define (contracted id)
+ (let ([v (value id)])
+ (if (has-contract? v)
+ (list id (cons 'info (contract-name (value-contract v))))
+ (entry id))))
+ (define (entry id)
+ (let ((sign (eval `(,autodoc* ',id #f)
+ (module-spec->namespace mod #f #f))))
+ (if sign (list id (cons 'signature sign)) (list id))))
+ (define (extract-ids ls)
+ (append-map (lambda (idls)
+ (map car (cdr idls)))
+ ls))
+ (define (classify-ids ids)
+ (let loop ([ids ids] [procs '()] [vars '()])
+ (cond [(null? ids)
+ `((procs ,@(map entry (reverse procs)))
+ (vars ,@(map list (reverse vars))))]
+ [(procedure? (value (car ids)))
+ (loop (cdr ids) (cons (car ids) procs) vars)]
+ [else (loop (cdr ids) procs (cons (car ids) vars))])))
+ (let-values ([(reg syn)
+ (module-compiled-exports
+ (get-module-code (resolve-module-path mod #f)))])
+ (let ([syn (map contracted (extract-ids syn))]
+ [reg (extract-ids reg)])
+ `((syntax ,@syn) ,@(classify-ids reg)))))
diff --git a/scheme/racket/geiser/eval.rkt b/scheme/racket/geiser/eval.rkt
index 12c77ae..f1f3f51 100644
--- a/scheme/racket/geiser/eval.rkt
+++ b/scheme/racket/geiser/eval.rkt
@@ -12,14 +12,12 @@
#lang racket
(provide eval-in
- compile-in
load-file
- compile-file
macroexpand
make-repl-reader)
-(require geiser/enter geiser/modules geiser/autodoc)
+(require geiser/enter geiser/modules)
(require errortrace/errortrace-lib)
(define last-result (void))
@@ -55,17 +53,11 @@
(define (eval-in form spec lang)
(write (call-with-result
(lambda ()
- (update-signature-cache spec form)
(eval form (module-spec->namespace spec lang)))))
(newline))
-(define compile-in eval-in)
-
(define (load-file file)
- (load-module file (current-output-port) (last-namespace))
- (update-signature-cache file))
-
-(define compile-file load-file)
+ (load-module file (current-output-port) (last-namespace)))
(define (macroexpand form . all)
(let ([all (and (not (null? all)) (car all))])
diff --git a/scheme/racket/geiser/main.rkt b/scheme/racket/geiser/main.rkt
index 4915b68..0c7de4e 100644
--- a/scheme/racket/geiser/main.rkt
+++ b/scheme/racket/geiser/main.rkt
@@ -32,10 +32,18 @@
geiser/autodoc)
(define (geiser:eval lang)
- (lambda (form spec) (eval-in form spec lang)))
-(define geiser:compile compile-in)
-(define geiser:load-file load-file)
-(define geiser:compile-file compile-file)
+ (lambda (form spec)
+ (update-signature-cache spec form)
+ (eval-in form spec lang)))
+
+(define geiser:compile geiser:eval)
+
+(define (geiser:load-file file)
+ (update-signature-cache file)
+ (load-file file))
+
+(define geiser:compile-file geiser:load-file)
+
(define geiser:autodoc autodoc)
(define geiser:help get-help)
(define geiser:completions symbol-completions)
diff --git a/scheme/racket/geiser/modules.rkt b/scheme/racket/geiser/modules.rkt
index 0591a92..8e85570 100644
--- a/scheme/racket/geiser/modules.rkt
+++ b/scheme/racket/geiser/modules.rkt
@@ -18,10 +18,9 @@
namespace->module-path-name
module-path-name->name
module-spec->path-name
- module-list
- module-exports)
+ module-list)
-(require srfi/13 syntax/modresolve syntax/modcode geiser/enter)
+(require srfi/13 geiser/enter)
(define (ensure-module-spec spec)
(cond [(symbol? spec) spec]
@@ -141,38 +140,8 @@
(update-module-cache)
module-cache)
-(define (module-exports mod)
- (define (value id)
- (with-handlers ([exn? (const #f)])
- (dynamic-require mod id (const #f))))
- (define (contracted id)
- (let ([v (value id)])
- (if (has-contract? v)
- (cons id (contract-name (value-contract v)))
- id)))
- (define (extract-ids ls)
- (append-map (lambda (idls)
- (map car (cdr idls)))
- ls))
- (define (classify-ids ids)
- (let loop ([ids ids] [procs '()] [vars '()])
- (cond [(null? ids)
- `((procs ,@(map contracted (reverse procs)))
- (vars ,@(map contracted (reverse vars))))]
- [(procedure? (value (car ids)))
- (loop (cdr ids) (cons (car ids) procs) vars)]
- [else (loop (cdr ids) procs (cons (car ids) vars))])))
- (let-values ([(reg syn)
- (module-compiled-exports
- (get-module-code (resolve-module-path mod #f)))])
- (let ([syn (map contracted (extract-ids syn))]
- [reg (extract-ids reg)])
- `((syntax ,@syn) ,@(classify-ids reg)))))
-
(define (startup)
(thread update-module-cache)
(void))
(startup)
-
-;;; modules.rkt ends here