[nongnu] elpa/geiser-racket 2494b95 068/191: Document browser improvements, and Racket using them

[Philip Kaludercic]

branch: elpa/geiser-racket
commit 2494b9512317aadb73aa780efc2fe71d7b864269
Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
Commit: Jose Antonio Ortega Ruiz <jao@gnu.org>

    Document browser improvements, and Racket using them
    
    We have a new "manual lookup" command, and Racket now displays a doc
    browser buffer for help with a button activating it. In the process,
    we've cleaned-up a little mess in geiser-eval.el and geiser-doc.el,
    and refactored the affected Racket modules.
    
    Next in line is providing manual lookup for Guile.
---
 geiser/autodoc.rkt   | 75 ++++++++++++++++++++++++++++++++++++----------------
 geiser/locations.rkt | 11 +++-----
 geiser/main.rkt      |  2 ++
 geiser/modules.rkt   | 21 ++++++++++++---
 4 files changed, 76 insertions(+), 33 deletions(-)

diff --git a/geiser/autodoc.rkt b/geiser/autodoc.rkt
index 54cac24..02b4f0f 100644
--- a/geiser/autodoc.rkt
+++ b/geiser/autodoc.rkt
@@ -11,19 +11,57 @@
 
 #lang racket
 
-(provide autodoc module-exports update-signature-cache get-help)
+(provide autodoc
+         symbol-documentation
+         module-exports
+         update-signature-cache
+         get-help)
 
 (require racket/help
-         syntax/modcode
-         syntax/modresolve
          geiser/utils
          geiser/modules
          geiser/locations)
 
 (define (get-help symbol mod)
-  (with-handlers ([exn? (lambda (_)
-                          (eval `(help ,symbol)))])
-    (eval `(help ,symbol #:from ,(ensure-module-spec mod)))))
+  (if (eq? symbol mod)
+      (get-mod-help mod)
+      (with-handlers ([exn? (lambda (_)
+                              (eval `(help ,symbol)))])
+        (eval `(help ,symbol #:from ,(ensure-module-spec mod))))))
+
+(define (get-mod-help mod)
+  (let-values ([(ids syns) (module-identifiers mod)])
+    (let ([sym (cond [(not (null? syns)) (car syns)]
+                     [(not (null? ids)) (car ids)]
+                     [else #f])])
+      (and sym (get-help sym mod)))))
+
+(define (symbol-documentation id)
+  (let* ([val (value id (symbol-module id))]
+         [sign (autodoc* id)])
+    (and sign
+         (list (cons 'signature (autodoc* id #f))
+               (cons 'docstring (docstring id val sign))))))
+
+(define (docstring id val sign)
+  (let* ([mod (assoc 'module (cdr sign))]
+         [mod (if mod (cdr mod) "<unknown>")])
+    (if val
+        (format "A ~a in module ~a.~a~a"
+                (if (procedure? val) "procedure" "variable")
+                mod
+                (if (procedure? val)
+                    ""
+                    (format "~%~%Value:~%~%  ~a" val))
+                (if (has-contract? val)
+                    (format "~%~%Contract:~%~%  ~a"
+                            (contract-name (value-contract val)))
+                    ""))
+        (format "A syntax object in module ~a." mod))))
+
+(define (value id mod)
+  (with-handlers ([exn? (const #f)])
+    (dynamic-require mod id (const #f))))
 
 (define (autodoc ids)
   (if (not (list? ids))
@@ -33,7 +71,8 @@
 (define (autodoc* id (extra #t))
   (define (val)
     (with-handlers ([exn? (const "")])
-      (format "~.a" (namespace-variable-value id))))
+      (parameterize ([error-print-width 60])
+        (format "~.a" (namespace-variable-value id)))))
   (and
    (symbol? id)
    (let* ([loc (symbol-location* id)]
@@ -201,11 +240,8 @@
     (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)])
+    (let ([v (value id mod)])
       (if (has-contract? v)
           (list id (cons 'info (contract-name (value-contract v))))
           (entry id))))
@@ -213,22 +249,15 @@
     (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)))
+            [(procedure? (value (car ids) mod))
              (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)]
-          [subm (map list (or (submodules mod) '()))])
-      `((syntax ,@syn) ,@(classify-ids reg) (modules ,@subm)))))
+  (let-values ([(ids syn) (module-identifiers mod)])
+    `(,@(classify-ids ids)
+      (syntax ,@(map contracted syn))
+      (modules ,@(map list (or (submodules mod) '()))))))
diff --git a/geiser/locations.rkt b/geiser/locations.rkt
index 7f69d3a..4715b8f 100644
--- a/geiser/locations.rkt
+++ b/geiser/locations.rkt
@@ -14,8 +14,8 @@
 (provide symbol-location
          symbol-location*
          module-location
-         symbol-module-name
-         symbol-module-path-name)
+         symbol-module
+         symbol-module-name)
 
 (require geiser/utils geiser/modules)
 
@@ -42,13 +42,10 @@
         (make-location name path #f)
         (module-location sym))))
 
-(define symbol-module-path-name (compose cdr symbol-location*))
+(define symbol-module (compose cdr symbol-location*))
 
 (define symbol-module-name
-  (compose module-path-name->name symbol-module-path-name))
+  (compose module-path-name->name symbol-module))
 
 (define (module-location sym)
   (make-location sym (module-spec->path-name sym) 1))
-
-
-;;; locations.rkt ends here
diff --git a/geiser/main.rkt b/geiser/main.rkt
index 0c7de4e..c759089 100644
--- a/geiser/main.rkt
+++ b/geiser/main.rkt
@@ -22,6 +22,7 @@
          geiser:module-location
          geiser:module-exports
          geiser:autodoc
+         geiser:symbol-documentation
          geiser:help
          geiser:no-values)
 
@@ -52,6 +53,7 @@
 (define geiser:module-location module-location)
 (define geiser:module-exports module-exports)
 (define geiser:macroexpand macroexpand)
+(define geiser:symbol-documentation symbol-documentation)
 (define (geiser:no-values) (values))
 
 ;;; main.rkt ends here
diff --git a/geiser/modules.rkt b/geiser/modules.rkt
index 02fd460..eac3a6c 100644
--- a/geiser/modules.rkt
+++ b/geiser/modules.rkt
@@ -18,10 +18,14 @@
          namespace->module-path-name
          module-path-name->name
          module-spec->path-name
+         module-identifiers
          module-list
          submodules)
 
-(require srfi/13 geiser/enter)
+(require srfi/13
+         syntax/modcode
+         syntax/modresolve
+         geiser/enter)
 
 (define (ensure-module-spec spec)
   (cond [(symbol? spec) spec]
@@ -48,7 +52,7 @@
 
 (define (namespace->module-path-name ns)
   (let ([rmp (variable-reference->resolved-module-path
-              (eval '(#%variable-reference) ns))])
+              (eval '(#%variable-reference) (or ns (current-namespace))))])
     (and (resolved-module-path? rmp)
          (resolved-module-path-name rmp))))
 
@@ -57,7 +61,7 @@
        (or (get-path spec)
            (register-path spec
                           (namespace->module-path-name
-                           (module-spec->namespace spec) #f #f)))))
+                           (module-spec->namespace spec #f #f))))))
 
 (define (module-path-name->name path)
   (cond [(path? path)
@@ -83,6 +87,17 @@
 (define namespace->module-name
   (compose module-path-name->name namespace->module-path-name))
 
+(define (module-identifiers mod)
+  (define (extract-ids ls)
+    (append-map (lambda (idls)
+                  (map car (cdr idls)))
+                ls))
+  (let-values ([(reg syn)
+                (module-compiled-exports
+                 (get-module-code (resolve-module-path
+                                   (ensure-module-spec mod) #f)))])
+    (values (extract-ids reg) (extract-ids syn))))
+
 (define (skippable-dir? path)
   (call-with-values (lambda () (split-path path))
     (lambda (_ basename __)