[nongnu] elpa/geiser-chez cf5ef755d7 1/2: better autodoc via data from chez-docs

[ELPA Syncer]

branch: elpa/geiser-chez
commit cf5ef755d7152c6a21b1655fb85ea02cb16ae285
Author: jao <jao@gnu.org>
Commit: jao <jao@gnu.org>

    better autodoc via data from chez-docs
---
 geiser-chez.el            | 29 ++++++++++++++-----------
 src/geiser/geiser-data.ss | 49 ++++++++++++++++++++++++++++++++++++++++++
 src/geiser/geiser.ss      | 54 ++++++++++++++++++++++++++++++++++++++---------
 3 files changed, 110 insertions(+), 22 deletions(-)

diff --git a/geiser-chez.el b/geiser-chez.el
index 4e087da686..92bede7e4c 100644
--- a/geiser-chez.el
+++ b/geiser-chez.el
@@ -1,4 +1,4 @@
-;;; geiser-chez.el --- Chez Scheme's implementation of the geiser protocols  
-*- lexical-binding: t; -*-
+;;; geiser-chez.el --- Chez and Geiser talk to each other  -*- 
lexical-binding: t; -*-
 
 ;; Author: Peter <craven@gmx.net>
 ;; Maintainer: Jose A Ortega Ruiz <jao@gnu.org>
@@ -84,8 +84,8 @@ host."
   (expand-file-name "src" (file-name-directory load-file-name))
   "Directory where the Chez scheme geiser modules are installed.")
 
-(defun geiser-chez--init-file ()
-  "Possibly remote init file, when it exists, as a list."
+(defun geiser-chez--init-files ()
+  "Possibly remote init file(s), when they exist, as a list."
   (let* ((file (and (stringp geiser-chez-init-file)
                     (expand-file-name geiser-chez-init-file)))
          (file (and file (concat (file-remote-p default-directory) file))))
@@ -94,22 +94,27 @@ host."
       (geiser-log--info "Init file not readable (%s)" file)
       nil)))
 
-(defun geiser-chez--module-files ()
-  "Possibly remote list of scheme files used by chez."
-  (let ((local-file (expand-file-name "geiser/geiser.ss" 
geiser-chez-scheme-dir)))
+(defun geiser-chez--module-file (file)
+  "Copy, if needed, the given scheme file to its remote destination.
+Return its local name."
+  (let ((local (expand-file-name (concat "geiser/" file) 
geiser-chez-scheme-dir)))
     (if (file-remote-p default-directory)
         (let* ((temporary-file-directory (temporary-file-directory))
                (temp-dir (make-temp-file "geiser" t))
                (remote (concat (file-name-as-directory temp-dir) "geiser.ss")))
           (with-temp-buffer
-            (insert-file-contents local-file)
+            (insert-file-contents local)
             (write-file remote))
-          (list (file-local-name remote)))
-      (list local-file))))
+          (file-local-name remote))
+      local)))
+
+(defun geiser-chez--module-files ()
+  "List of (possibly copied to a tramped remote) scheme files used by chez."
+  (mapcar #'geiser-chez--module-file '("geiser-data.ss" "geiser.ss")))
 
 (defun geiser-chez--parameters ()
   "Return a list with all parameters needed to start Chez Scheme."
-  (append (geiser-chez--init-file)
+  (append (cons "--compile-imported-libraries" (geiser-chez--init-files))
           (geiser-chez--module-files)
           geiser-chez-extra-command-line-parameters))
 
@@ -283,8 +288,8 @@ host."
   ;; (external-help geiser-chez--manual-look-up)
   ;; (check-buffer geiser-chez--guess)
   (keywords geiser-chez--keywords)
-  ;; (case-sensitive geiser-chez-case-sensitive-p)
-  )
+  (nested-definitions t)
+  (case-sensitive nil))
 
 (geiser-implementation-extension 'chez "ss")
 
diff --git a/src/geiser/geiser-data.ss b/src/geiser/geiser-data.ss
new file mode 100644
index 0000000000..f9fc81e342
--- /dev/null
+++ b/src/geiser/geiser-data.ss
@@ -0,0 +1,49 @@
+;;; geiser-data.ss -- autodoc and manuals data
+
+;; Copyright (c) 2022 Jose A Ortega Ruiz
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the Modified BSD License. You should
+;; have received a copy of the license along with this program. If
+;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
+
+;; Start date: Thu Oct 13, 2022 03:14
+
+;; The data in this file is a slightly modified version of the one provided by
+;; Travis Hinkelman in his chez-docs project over at
+;; https://github.com/hinkelman/chez-docs.  Most probably, we should automate
+;; the process by using chez-docs directly; this is a quick hack for
+;; expediency (yeah, famous last words).
+
+(library (geiser-data)
+
+  (export symbol-signature symbol-labels)
+  (import (chezscheme))
+
+  (define (make-hash d)
+    (let ((h (make-hashtable symbol-hash eq?)))
+      (for-each (lambda (x)
+                  (let ((id (car x))
+                        (sg (let ((a (with-input-from-string (cadr x) read)))
+                              (if (list? a) (cdr a) a))))
+                    (symbol-hashtable-set! h id (cons id (cons sg (cddr x))))))
+                d)
+      h))
+
+  (define (symbol-signature s)
+    (let ((x (or (symbol-hashtable-ref csug-data s #f)
+                 (symbol-hashtable-ref tspl-data s #f))))
+      (and x (list? (cadr x)) (cadr x))))
+
+  (define (symbol-labels s)
+    (define (label t)
+      (let ((e (symbol-hashtable-ref t s #f)))
+        (and e (caddr e))))
+    (list (cons 'csug (label csug-data)) (cons 'tspl (label tspl-data))))
+
+  (define tspl-alist '((=> "=>" "control.html#./control:s16") (_ "_" 
"syntax.html#./syntax:s26") (... "..." "syntax.html#./syntax:s26") (&assertion 
"&assertion" "exceptions.html#./exceptions:s21") (&condition "&condition" 
"exceptions.html#./exceptions:s13") (&error "&error" 
"exceptions.html#./exceptions:s22") (&i/o "&i/o" 
"exceptions.html#./exceptions:s32") (&i/o-decoding "&i/o-decoding" 
"exceptions.html#./exceptions:s42") (&i/o-encoding "&i/o-encoding" 
"exceptions.html#./exceptions:s43" [...]
+
+  (define csug-alist '(($system "$system" "syntax.html#./syntax:s35") 
(&continuation "&continuation" "system.html#./system:s6") (&format "&format" 
"system.html#./system:s4") (&source "&source" "system.html#./system:s5") (< "(< 
real1 real2 real3 ...)" "numeric.html#./numeric:s67") (<= "(<= real1 real2 
real3 ...)" "numeric.html#./numeric:s67") (= "(= num1 num2 num3 ...)" 
"numeric.html#./numeric:s67") (> "(> real1 real2 real3 ...)" 
"numeric.html#./numeric:s67") (>= "(>= real1 real2 real3 .. [...]
+
+  (define tspl-data (make-hash tspl-alist))
+  (define csug-data (make-hash csug-alist)))
diff --git a/src/geiser/geiser.ss b/src/geiser/geiser.ss
index 654a346364..806f5931d8 100644
--- a/src/geiser/geiser.ss
+++ b/src/geiser/geiser.ss
@@ -1,3 +1,14 @@
+;;; geiser.ss -- emacs/scheme interface
+
+;; Copyright (c) 2022 Jose A Ortega Ruiz
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the Modified BSD License. You should
+;; have received a copy of the license along with this program. If
+;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
+
+;; Start date: Tue Apr 26 22:27:26 2016 +0200
+
 (library (geiser)
   (export geiser:eval
           geiser:completions
@@ -11,12 +22,17 @@
           geiser:module-location
           geiser:add-to-load-path)
   (import (chezscheme))
+  (import (geiser-data))
 
   (define-syntax as-string
     (syntax-rules () ((_ b ...) (with-output-to-string (lambda () b ...)))))
 
   (define (write-to-string x) (as-string (write x)))
-  (define (pretty-string x) (as-string (pretty-print x)))
+
+  (define (pretty-string x)
+    (parameterize ((print-extended-identifiers #t)
+                   (print-vector-length #t))
+      (as-string (pretty-print x))))
 
   (define (call-with-result thunk)
     (let ((output-string (open-output-string)))
@@ -35,7 +51,7 @@
                   (lambda ()
                     (parameterize ((current-output-port output-string)) 
(thunk)))
                 (lambda result
-                  `((result ,(pretty-string
+                  `((result ,(write-to-string
                               (if (null? (cdr result)) (car result) result)))
                     (output . ,(get-output-string output-string))))))))))
       (newline)
@@ -90,15 +106,27 @@
 
   (define not-found (gensym))
 
+  (define current-environment (make-parameter environment?))
+
+  (define (module-env env)
+    (cond ((environment? env) env)
+          ((list? env) (environment env))
+          (else #f)))
+
   (define (try-eval sym . env)
     (call/cc
      (lambda (k)
        (with-exception-handler (lambda (e) (k not-found))
-         (lambda () (if (null? env) (eval sym) (eval sym (car env))))))))
+         (let ((env (and (not (null? env)) (module-env (car env)))))
+           (lambda () (if env (eval sym env) (eval sym))))))))
 
   (define (geiser:eval module form)
     (call-with-result
-     (lambda () (if module (eval form (environment module)) (eval form)))))
+     (lambda ()
+       (parameterize ((current-environment (module-env module)))
+         (if (environment? (current-environment))
+             (eval form (current-environment))
+             (eval form))))))
 
   (define (geiser:module-completions prefix . rest)
     (define (substring? s1 s2)
@@ -155,14 +183,19 @@
     (define max-len 80)
     (define sub-str "...")
     (define sub-len (- max-len (string-length sub-str)))
-    (let* ((s (write-to-string x))
+    (let* ((s (pretty-string x))
            (l (string-length s)))
       (if (<= l max-len) s (string-append (substring s 0 sub-len) sub-str))))
 
+  (define (docs->parameter-list id)
+    (let ((s (symbol-signature id)))
+      (and s (list s))))
+
   (define (operator-arglist operator)
-    (define (procedure-parameter-list p)
+    (define (procedure-parameter-list id p)
       (and (procedure? p)
            (or (source->parameter-list p)
+               (docs->parameter-list id)
                (arity->parameter-list p))))
     (define (autodoc-arglist* args req)
       (cond ((null? args) (list (list* "required" (reverse req))))
@@ -172,12 +205,13 @@
     (define (autodoc-arglist arglist) (autodoc-arglist* arglist '()))
     (let ([binding (try-eval operator)])
       (if (not (eq? binding not-found))
-          (let ([arglists (procedure-parameter-list binding)])
+          (let ([arglists (procedure-parameter-list operator binding)])
             (cond ((null? arglists) `(,operator ("args" (("required")))))
                   (arglists
                    `(,operator ("args" ,@(map autodoc-arglist arglists))))
                   (else `(,operator ("value" . ,(value->string binding))))))
-          '())))
+          (let ((s (symbol-signature operator)))
+            (if s `(,operator ("args" (("required" ,@s)))) '())))))
 
   (define (geiser:autodoc ids)
     (cond ((null? ids) '())
@@ -185,8 +219,8 @@
           ((not (symbol? (car ids))) (geiser:autodoc (cdr ids)))
           (else (map operator-arglist ids))))
 
-  (define (geiser:symbol-location id)
-    (let* ([b (try-eval id)]
+  (define (geiser:symbol-location id . env)
+    (let* ([b (try-eval id (current-environment))]
            [c (and (not (eq? not-found b))
                    ((inspect/object b) 'code))])
       (if c