Better module help

We now display procedure signatures in module help, and keep a cache
in Guile, using procedure properties.

7 files changed, 129 insertions, 104 deletions

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