[nongnu] elpa/geiser-stklos 9db60a7 3/3: General enhancements (no user-perceptible changes)

[ELPA Syncer]

branch: elpa/geiser-stklos
commit 9db60a7e751c97e30dd528e2a96ff19575b618d2
Author: Jeronimo Pellegrini <j_p@aleph0.info>
Commit: Jeronimo Pellegrini <j_p@aleph0.info>

    General enhancements (no user-perceptible changes)
---
 geiser-stklos.el | 50 +++++++++++++++++++++++++++++-----------
 geiser.stk       | 70 +++++++++++++++++++++++++++++++++-----------------------
 2 files changed, 79 insertions(+), 41 deletions(-)

diff --git a/geiser-stklos.el b/geiser-stklos.el
index a2fe50b..cf051ed 100644
--- a/geiser-stklos.el
+++ b/geiser-stklos.el
@@ -9,7 +9,7 @@
 ;; Keywords: languages, stklos, scheme, geiser
 ;; Package-Requires: ((emacs "24.4") (geiser "0.16"))
 ;; SPDX-License-Identifier: BSD-3-Clause
-;; Version: 1.3
+;; Version: 1.4
 
 ;; This file is not part of GNU Emacs.
 
@@ -17,7 +17,7 @@
 
 ;;; Commentary:
 ;;
-;; Geiser, STklos and Geisr-STklos
+;; Geiser, STklos and Geiser-STklos
 ;; ───────────────────────────────
 ;;
 ;; Geiser (https://www.nongnu.org/geiser/) is a collection of Emacs
@@ -40,7 +40,7 @@
 ;; * macroexpansion
 ;; * symbol completion
 ;; * listing of module exported symbols
-;; * autodoc (signature of procedurs and values of symbols are displayed in 
the minibuffer
+;; * autodoc (signature of procedures and values of symbols are displayed in 
the minibuffer
 ;;   when the mouse hovers over their names)
 ;; * symbol documentation (docstrings for procedures, and values of variables)
 ;;
@@ -127,6 +127,20 @@ option."
   :type 'boolean
   :group 'geiser-stklos)
 
+;; (geiser-custom--defcustom geiser-stklos-log-file
+;;     nil
+;;   "Name of the file where the STklos part of the system will log its
+;; actions."
+;;   :type 'string
+;;   :group 'geiser-stklos)
+
+;; (geiser-custom--defcustom geiser-emacs-log-buffer
+;;     '*geiser-log*
+;;   "Name of the Emacs buffer where the Emacs Lisp part of the system
+;; will log its actions."
+;;   :type 'symbol
+;;   :group 'geiser-stklos)
+
 
 
 ;;; REPL support:
@@ -167,23 +181,32 @@ This function uses `geiser-stklos-init-file' if it 
exists."
   "Translates symbols into Scheme procedure calls from geiser.stk.
 Argument PROC is the procedure to be called.
 Optional argument ARGS are the arguments to the procedure."
+  ;; Adapted from Geiser-Gauche
   (cl-case proc
+    ((autodoc symbol-location completions)
+     (format "(eval '(geiser:%s %s {{cur-module}}) (find-module 'GEISER))"
+            proc (mapconcat #'identity args " ")))
+
     ((eval compile)
-     (let ((form (mapconcat #'identity (cdr args) " "))
-           (module (cond ((string-equal "'()" (car args))
-                          "'()")
-                         ((and (car args))
-                          (concat "'" (car args)))
-                         (t
-                          "#f"))))
+     (let ((module (if (car args) (concat "'" (car args)) "#f"))
+                (form (mapconcat #'identity (cdr args) " ")))
        (format "((in-module GEISER geiser:eval) %s '%s)" module form)))
+       ;; ;; The {{cur-module}} cookie is replaced by the current module for
+       ;; ;; commands that need it
+       ;; (replace-regexp-in-string
+            ;;  "{{cur-module}}"
+            ;;  (if (string= module "'#f")
+            ;;      (format "'%s" (geiser-stklos--get-module))
+            ;;    module)
+            ;;  (format "(eval '(geiser:eval %s '%s) (find-module 'GEISER))" 
module form))))
     ((load-file compile-file)
      (format "((in-module GEISER geiser:load-file) %s)" (car args)))
     ((no-values)
      "((in-module GEISER geiser:no-values))")
+    ;; The rest of the commands are all evaluated in the geiser module
     (t
      (let ((form (mapconcat #'identity args " ")))
-       (format "(geiser:%s %s)" proc form)))))
+       (format "((in-module GEISER geiser:%s) %s)" proc form)))))
 
 ;;; Modules
 
@@ -295,7 +318,7 @@ if a closing match is not found."
 ;; This will possibly fail:
 ;;
 ;; - with false negative, if the buffer is running STklos
-;; but th euser is in not in the stklos module, AND
+;; but the user is in not in the stklos module, AND
 ;; the user was not in the stklos module recently, so
 ;; there are no "stklos" strings in the buffer.
 ;;
@@ -336,7 +359,8 @@ Argument BINARY is a string containing the binary name."
 (defun geiser-stklos--startup (_remote)
   "Hook for startup.  The argument is ignored."
   (let ((geiser-log-verbose-p t))
-    (compilation-setup t)))
+    (compilation-setup t)
+    (geiser:eval "GEISER" geiser:set-log-file geiser-stklos-log-file)))
 
 
 (defconst geiser-stklos-builtin-keywords
diff --git a/geiser.stk b/geiser.stk
index 549d962..84b6add 100644
--- a/geiser.stk
+++ b/geiser.stk
@@ -21,7 +21,21 @@
           geiser:module-exports
           geiser:symbol-documentation
           geiser:autodoc
-          geiser:no-values)
+          geiser:no-values
+          geiser:set-log-file)
+
+
+(define geiser-log-file #f)
+
+;; Opens the Geiser log file
+(define (geiser:set-log-file name)
+  (when (string? name)
+    (set! geiser-log-file (open-output-file name))))
+
+(define (geiser-format port . rest)
+  (when (output-port? port)
+    (apply format (cons port rest))
+    (flush-output-port port)))
 
 ;; executes thunk, with all its output (standar and error) redirected
 ;; to a string.
@@ -50,8 +64,8 @@
 ;; =>  ((result "1" "2" "3") (output . "OK"))
 ;;
 (define (call-with-result thunk)
-  (let* ((result (if #f #f))
-         (output (if #f #f)))
+  (let* ((result #void)
+         (output #void))
     
     (set! output
           (with-handler (lambda (exn)
@@ -65,40 +79,40 @@
           (cond
            ((list? result)
             (map (lambda (v) (with-all-output-to-string (lambda () (write 
v)))) result))
-             ((eq? result (if #f #t))
-              ;;              '())
-              (list output))
-             (else
-              (list (with-all-output-to-string (lambda () (write result)))))))
+           ((eq? result #void)
+            (list output))
+           (else
+            (list (with-all-output-to-string (lambda () (write result)))))))
     
     (let ((out-form
                  `((result ,@result)
                    (output . ,output))))
       (write out-form)
-      (write-to-log '[[RESPONSE]])
-      (write-to-log out-form))
+      (geiser-format geiser-log-file "call-with-result response: ~s~%" 
out-form))
     
     (newline)))
 
-;; 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)
-  (values))
 
 ;; evaluates form inside a module.
 ;; the result is in the same format as call-with-result.
 ;;
-;; Example:
+;; Examples:
+;; 
 ;; (geiser:eval #f '(begin (display "OK") (values 1 2 3)))
 ;; => ((result "1" "2" "3") (output . "OK"))
 ;;
+;;
+;; (define-module a
+;;   (export b)
+;;   (define b -2))
+;;
+;; (geiser:eval 'a 'b)
+;; => ((result "-2") (output . ""))
+;;
 (define (geiser:eval module-name form . rest)
-  
+  (geiser-format geiser-log-file "_________________~%")
+  (geiser-format geiser-log-file "geiser:eval form: ~s~%" form)
+
   ;; All calls start at toplevel
   (let ((module (or (and (symbol? module-name )
                         (find-module module-name))
@@ -108,12 +122,13 @@
                       (else
                        (write `((error (key . ,(error-object-message err)))))))
                    (lambda () (eval form module)))))
-      
-      (write-to-log form)
-      (call-with-result thunk))))
+      (let ((ret (call-with-result thunk)))
+        (geiser-format geiser-log-file "geiser:eval return: ~s~%" ret)
+        ret))))
 
-;; Load a file
 
+;; Load a file in STklos
+;;
 (define (geiser:load-file file)
   (let* ((file (if (symbol? file) (symbol->string file) file))
          (found-file (geiser-find-file file)))
@@ -132,8 +147,6 @@
 (define (geiser:macroexpand form . rest)
   (format "~S" (macro-expand form)))
 
-
-
 ;; do not use string-index, because the native STklos version
 ;; is different from that in SRFI-13, and we can't tell in advance
 ;; what's the correct way to call it...
@@ -145,6 +158,7 @@
                    (string-ref name i)))
          (name-match-with-start? prefix name (+ 1 i)))
         (else #f)))
+
 (define (name-match? prefix name) (name-match-with-start? prefix name 0))
 
 ;; Geiser calls this procedure when it wants to complete
@@ -298,7 +312,7 @@
 ;; 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
+;; *** The lists MUST BE MUTABLE! (hence the use of
 ;;     "list-copy" in the examples below ***
 ;;
 ;; (define a (list-copy '(1 2 . 3)))