[nongnu] elpa/geiser-stklos fc33f45 01/30: Initial Commit

[Philip Kaludercic]

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

    Initial Commit
---
 README.md        |  29 ++++++
 geiser-stklos.el | 309 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 geiser.stk       | 250 ++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 588 insertions(+)

diff --git a/README.md b/README.md
new file mode 100644
index 0000000..4d820b1
--- /dev/null
+++ b/README.md
@@ -0,0 +1,29 @@
+# Geiser for STklos
+
+See the Geiser anual for usage.
+
+# Unsupported features
+
+* finding the definition of a symbol (no support in STklos)
+* seeing callees and callers of a procedure (no support in STklos)
+* looking up symbols in the manual (would need to download the index from 
STklos manual and parse the DOM of its index; a bit too much, maybe someday...)
+
+# Bugs
+
+See the issue tracker in Gitlab.
+
+# About the implementation:
+
+The following functions were defined on the STklos side:
+
+* `geiser:eval`
+* `geiser:load-file`
+* `geiser:add-to-load-path`
+* `geiser:macroexpand`
+* `geiser:no-values`
+* `geiser:symbol-documentation`
+* `geiser:module-exports`
+* `geiser:module-completions`
+* `geiser:completions`
+
+They have comments that help understand how they work.
diff --git a/geiser-stklos.el b/geiser-stklos.el
new file mode 100644
index 0000000..1be3862
--- /dev/null
+++ b/geiser-stklos.el
@@ -0,0 +1,309 @@
+;;; geiser-stklos.el -- STklos Scheme implementation of the geiser protocols
+
+;; Author: Jeronimo Pellegrini <j_p@aleph0.info>
+;; Maintainer:
+;; Keywords: languages, stklos, scheme, geiser
+;; Homepage: 
+;; Package-Requires: ((emacs "24.4") (geiser-core "1.0"))
+;; SPDX-License-Identifier: BSD-3-Clause
+;; Version: 1.0
+
+
+;;; Code:
+
+(require 'geiser-connection)
+(require 'geiser-syntax)
+(require 'geiser-custom)
+(require 'geiser-base)
+(require 'geiser-eval)
+(require 'geiser-edit)
+(require 'geiser-log)
+(require 'geiser)
+
+(require 'compile)
+(require 'info-look)
+
+(eval-when-compile (require 'cl-lib))
+
+
+
+;;; Customization:
+
+(defgroup geiser-stklos
+  nil
+  "Customization for Geiser's STklos Scheme flavour."
+  :group 'geiser)
+
+(geiser-custom--defcustom geiser-stklos-binary
+    "stklos"
+  "Name to use to call the STklos executable when starting a REPL."
+  :type '(choice string (repeat string))
+  :group 'geiser-stklos)
+
+
+(geiser-custom--defcustom geiser-stklos-extra-command-line-parameters
+    '()
+  "Additional parameters to supply to the STklos binary."
+  :type '(repeat string)
+  :group 'geiser-stklos)
+
+(geiser-custom--defcustom geiser-stklos-extra-keywords
+    nil
+  "Extra keywords highlighted in STklos scheme buffers."
+  :type '(repeat string)
+  :group 'geiser-stklos)
+
+;; FIXME: should ask STklos,
+;; (read-case-sensitive) returns the proper value, but
+;; this should be done during REPL startup.
+;; And the value can be changed later, because read-case-sensitive
+;; is a parameter object!
+(geiser-custom--defcustom geiser-stklos-case-sensitive
+    t
+  "Non-nil means keyword highlighting is case-sensitive. You need
+to restart Geiser in order for it to see you've changed this
+option."
+  :type 'boolean
+  :group 'geiser-stklos)
+
+
+
+;;; REPL support:
+
+(defvar geiser-stklos-scheme-dir
+  (expand-file-name "" (file-name-directory load-file-name))
+  "Directory where the STklos scheme geiser modules are installed.")
+
+;; returns the name of the executable.
+(defun geiser-stklos--binary ()
+  (if (listp geiser-stklos-binary)
+      (car geiser-stklos-binary)
+    geiser-stklos-binary))
+
+;; a list of strings to be passed to STklos
+(defun geiser-stklos--parameters ()
+  "Return a list with all parameters needed to start STklos Scheme.
+This function uses `geiser-stklos-init-file' if it exists."
+  `(,@geiser-stklos-extra-command-line-parameters
+    "-i" ;; do not use ANSI color codes
+    "-n" ;; do not use the line editor
+    "-l" ,(expand-file-name "geiser.stk" geiser-stklos-scheme-dir)))
+
+;; STklos' prompt is  "MODULE> ". The regexp is "[^>]*> ".
+;; Not perfect, because if a module has a ">" sign
+;; in its name, things break...
+(defconst geiser-stklos--prompt-regexp "[^>]*> ")
+
+
+;;; Evaluation support:
+
+;; Translates symbols into Scheme procedure calls from
+;; geiser.stk :
+(defun geiser-stklos--geiser-procedure (proc &rest args)
+  (cl-case proc
+    ((eval compile)
+     (let ((form (mapconcat 'identity (cdr args) " "))
+           (module (cond ((string-equal "'()" (car args))
+                          "'()")
+                         ((and (car args))
+                          (concat "'" (car args)))
+                         (t
+                          "#f"))))
+       (format "(geiser:eval %s '%s)" module form)))
+    ((load-file compile-file)
+     (format "(geiser:load-file %s)" (car args)))
+    ((no-values)
+     "(geiser:no-values)")
+    (t
+     (let ((form (mapconcat 'identity args " ")))
+       (format "(geiser:%s %s)" proc form)))))
+
+;;; Modules
+
+;; Regular expression used to try to guess which module
+;; the current file is associated to.
+(defconst geiser-stklos--module-re
+  "(define-module +\\([^) ]+\\)")
+
+
+;; from the start point, which must be an opening
+;; ( or [, find its closing match and return its
+;; position, or the end of buffer position if a
+;; closing match is not found.
+(defun find-close-par (&optional start-point)
+  (interactive)
+  (let ((start (if (null start-point)
+                   (point)
+                 start-point))
+        (opening '( ?\[ ?\( ))
+        (closing '( ?\] ?\) )))
+    (when (not (member (char-after start)
+                       opening))
+      (error "find-close-par: not ( or ["))
+    (let ((stack (list (char-after start)))
+          (p (+ 1 start)))
+      (while (not (or (= p (point-max))
+                      (null stack)))
+        (let ((c (char-after p)))
+          (cond ((member c closing)
+                 (pop stack))
+                ((member c opening)
+                 (push c stack))))                
+        (incf p))
+      p)))
+
+;; find which module should be used for the position where the
+;; cursor is.
+;; if the user is editing text inside a module definition -- which is
+;; between "(define-module " and its closing parenthesis, then
+;; the current module should be taken as that one, so defines and sets
+;; will be done inside that module.
+(defun geiser-stklos--get-module (&optional module)
+  (cond ((null module)
+         (let ((here (point)))
+           (save-excursion
+             ;; goto end of line, so if we are already exacly on the module
+             ;; definition, we'll be able to find it searching backwards:
+             (end-of-line)
+             ;; module defined BEFORE point:
+             (let ((module-begin (re-search-backward geiser-stklos--module-re 
nil t)))
+               (if module-begin
+                   ;; and we're not AFTER it was closed:
+                   (let ((module-end (find-close-par module-begin)))
+                     (if (< here module-end)
+                         (geiser-stklos--get-module 
(match-string-no-properties 1))
+                       :f))
+                 :f)))))
+        ((symbolp module) (geiser-stklos--get-module (symbol-name module))) ; 
try again, as string
+        ((listp module) module)
+        ((stringp module)
+         (condition-case e
+             (car (geiser-syntax--read-from-string module))
+           (progn (message (format "error -> %s" e))
+                  (error   :f))))
+        (t :f)))
+
+
+;; string sent to STklos to tell it to enter a module.
+(defun geiser-stklos--enter-command (module)
+  (format "(select-module %s)" module))
+
+
+;; Finds the beginning of the symbol around point.
+(defun geiser-stklos--symbol-begin (module)
+  (if module
+      (max (save-excursion (beginning-of-line) (point))
+           (save-excursion (skip-syntax-backward "^(>") (1- (point))))
+    (save-excursion (skip-syntax-backward "^'-()>") (point))))
+
+
+;; string sent to STklos to tell it to load a module.
+(defun geiser-stklos--import-command (module)
+  (format "(require \"%s\")" module))
+
+;; string sent to STklos to tell it to exit.
+;; (this could also be ",q"...)
+(defun geiser-stklos--exit-command () "(exit 0)")
+
+
+
+;;; Error display
+
+(defun geiser-stklos--display-error (module key msg)
+  (newline)
+  (when (stringp msg)
+    (save-excursion (insert msg))
+    (geiser-edit--buttonize-files))
+  (and (not key) msg (not (zerop (length msg)))))
+
+
+;;; Guessing wether a buffer is a STklos REPL buffer
+
+;; The function (geiser-stklos--guess) tries to
+;; ascertain whether a buffer is STklos Scheme.
+;; This will possibly fail:
+;;
+;; - with false negative, if the buffer is running STklos
+;; but th euser 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.
+;;
+;; - with false positive, if the buffer is not a STklos buffer,
+;; but there is a string "stklos>" there. I see no way
+;; to prevent this.
+(defconst geiser-stklos--guess-re
+  (regexp-opt '("stklos>")))
+
+(defun geiser-stklos--guess ()
+  (save-excursion
+    (goto-char (point-min))
+    (re-search-forward geiser-stklos--guess-re nil t)))
+
+;;; REPL startup
+
+;; Minimum version of STklos supported. If a less recent version
+;; is used, Geiser will refuse to start.
+(defconst geiser-stklos-minimum-version "1.40")
+
+;; this function obtains the version of the STklos binary
+;; available.
+(defun geiser-stklos--version (binary)
+  ;; use SRFI-176!!!
+  (cadr (assoc 'version
+               (read (shell-command-to-string
+                      (concat binary
+                              " -e \"(write (version-alist))\"" ))))))
+
+
+;; Function ran at startup
+(defun geiser-stklos--startup (remote)
+  (let ((geiser-log-verbose-p t))
+    (compilation-setup t)))
+
+
+;; These are symbols that we want to be highlighted in STklos code.
+(defconst geiser-stklos-builtin-keywords
+  '("assume"
+    "fluid-let"
+    "dotimes"
+    "macro-expand"
+    "define-struct"
+    "call/ec"
+    "with-handler" ))
+
+;; The symbols that are to be highlighted as keywords, besides
+;; the standard Scheme ones
+(defun geiser-stklos--keywords ()
+  (append (geiser-syntax--simple-keywords geiser-stklos-extra-keywords)
+          (geiser-syntax--simple-keywords geiser-stklos-builtin-keywords)))
+
+
+;;; Implementation definition:
+
+(define-geiser-implementation stklos
+  (binary                 geiser-stklos--binary)         ; ok
+  (arglist                geiser-stklos--parameters)     ; ok
+  (version-command        geiser-stklos--version)        ; ok
+  (minimum-version        geiser-stklos-minimum-version) ; ok
+  (repl-startup           geiser-stklos--startup)        ; ok
+  (prompt-regexp          geiser-stklos--prompt-regexp)  ; ok
+  (debugger-prompt-regexp nil) ;; no debugger
+  (enter-debugger         nil) ;; no debugger
+  (marshall-procedure     geiser-stklos--geiser-procedure)
+  (find-module            geiser-stklos--get-module)
+  (enter-command          geiser-stklos--enter-command)  ; ok
+  (exit-command           geiser-stklos--exit-command)   ; ok
+  (import-command         geiser-stklos--import-command) ; ok
+  (find-symbol-begin      geiser-stklos--symbol-begin)   ; ok
+  (display-error          geiser-stklos--display-error)
+  ;; (external-help geiser-stklos--manual-look-up) ;; cannot easily search by 
keyword
+  (check-buffer           geiser-stklos--guess)
+  (keywords               geiser-stklos--keywords)      ; ok
+  (case-sensitive         geiser-stklos-case-sensitive) ; ok
+  )
+
+(geiser-impl--add-to-alist 'regexp "\\.scm$" 'stklos t)
+(geiser-impl--add-to-alist 'regexp "\\.stk$" 'stklos t)
+
+
+(provide 'geiser-stklos)
diff --git a/geiser.stk b/geiser.stk
new file mode 100644
index 0000000..7610fdc
--- /dev/null
+++ b/geiser.stk
@@ -0,0 +1,250 @@
+;;; geiser.stk -- STklos Scheme implementation of the geiser protocols
+
+;; Author: Jeronimo Pellegrini <j_p@aleph0.info>
+;; Maintainer:
+;; Keywords: languages, stklos, scheme, geiser
+;; Homepage: 
+;; Package-Requires: ((emacs "24.4") (geiser-core "1.0"))
+;; SPDX-License-Identifier: BSD-3-Clause
+;; Version: 1.0
+
+;; executes thunk, with all its output (standar and error) redirected
+;; to a string.
+(define (with-all-output-to-string thunk)
+  (let ((out (open-output-string)))
+    (with-error-to-port out
+                        (lambda ()
+                          (with-output-to-port out
+                            thunk)))
+    (close-output-port out)
+    (get-output-string out)))
+
+
+;; call-with-result wraps output from geiser functions.
+;; The result is an assoc list with the keys:
+;;
+;; - result: the CAR is a list with the values returned
+;; - output: the CDR is a string with the output
+;;
+;; Example:
+;;
+;; (call-with-result (lambda () (display "OK") 42))
+;; =>  ((result "42") (output . "OK"))
+;;
+;;  (call-with-result (lambda () (display "OK") (values 1 2 3)))
+;; =>  ((result "1" "2" "3") (output . "OK"))
+;;
+(define (call-with-result thunk)
+  (let* ((result (if #f #f))
+         (output (if #f #f)))
+    
+    (set! output
+          (with-handler (lambda (exn)
+                            (with-output-to-string
+                              (lambda () (write (error-object-message exn)))))
+                        (with-all-output-to-string
+                         (lambda ()
+                           (call-with-values thunk (lambda v (set! result 
v)))))))
+    
+    (set! result
+          (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)))))))
+    
+    (let ((out-form
+                 `((result ,@result)
+                   (output . ,output))))
+      (write out-form)
+      (write-to-log '[[RESPONSE]])
+      (write-to-log out-form))
+    
+    (newline)))
+
+(define (write-to-log form)
+  (values))
+
+;; evaluates form inside a module.
+;; the result is in the same format as call-with-result.
+;;
+;; Example:
+;; (geiser:eval #f '(begin (display "OK") (values 1 2 3)))
+;; => ((result "1" "2" "3") (output . "OK"))
+;;
+(define (geiser:eval module-name form . rest)
+  
+  ;; All calls start at toplevel
+  (let ((module (or (and (symbol? module-name )
+                        (find-module module-name))
+                   (find-module 'stklos))))
+    (let ((thunk (guard
+                     (err
+                      (else
+                       (write `((error (key . ,(error-object-message err)))))))
+                   (lambda () (eval form module)))))
+      
+      (write-to-log form)
+      (call-with-result thunk))))
+
+  ;; Load a file
+
+  (define (geiser:load-file file)
+    (let* ((file (if (symbol? file) (symbol->string file) file))
+           (found-file (geiser-find-file file)))
+      (call-with-result
+       (lambda ()
+         (when found-file
+           (load found-file))))))
+
+;; Geiser calls this function to add a string to STklos'
+;; load path
+(define (geiser:add-to-load-path path)
+  (load-path (cons path (load-path))))
+
+;; Geiser will call this procedure when it wants to
+;; show the macro-expansion of a form.
+(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...
+(define (name-match-with-start? prefix name i)
+  (cond ((< (string-length name) (string-length prefix)) #f)
+        ((>= i (string-length prefix)) #t)
+        ((and (< i (string-length prefix))
+              (eq? (string-ref prefix i)
+                   (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
+;; a module's name for the user. We check if prefix is
+;; the prefix of a known module.
+;;
+;; Issue: we should be able to complete the names of
+;; arbitrary modules, including those which were not
+;; loaded yet, but that would be a bit too complex.
+(define (geiser:module-completions prefix . rest)
+  (filter (lambda (name) (name-match? prefix name))
+          (map symbol->string
+               (map module-name (all-modules)))))
+
+;; symbol completion. not sure if completing with all the symbols
+;; from the current module is OK, but it's a start...
+(define (geiser:completions prefix)
+  (filter (lambda (name) (name-match? prefix name))
+          (map symbol->string
+               (module-symbols (current-module)))))
+
+;; used in module-exports...
+(define-syntax push!
+  (syntax-rules ()
+    ((push! el lst)
+     (set! lst (cons el lst)))))
+
+;; given a module name (either symbol or string), return a list of
+;; symbols exported by the module. This list will be used as an assoc
+;; list, and the keys are:
+;;
+;; - "modules" - the CDR is a list of module names, each one wrapped in a list
+;; - "procs" - the CDR is a list of procedure names, each one wrapped in a list
+;; - "syntax" - the CDR is a list of macro names, each one wrapped in a list
+;; - "vars" - the CDR is a list of variable names, each one wrapped in a list
+;;
+;; Example:
+;;
+;; (define-module x
+;;   (export p q v s)
+;;   (define v 100)
+;;   (define (p) 200)
+;;   (define (q) 300)
+;;   (define-syntax s
+;;     (syntax-rules ()
+;;       ((s x) (- x)))))
+;;
+;;
+;; (geiser:module-exports 'x)
+;; => (list ("modules") ("procs" (p) (q)) ("syntax" (s)) ("vars" (v)))
+;;
+(define (geiser:module-exports module-name . rest)
+  (cond ((string? module-name)
+         (geiser:module-exports (string->symbol module-name)))
+        ((symbol? module-name)
+         (let ((module (find-module  module-name)))
+           (let ((exports (module-exports module)))
+             (let ((procs '())
+                   (syntaxes '())
+                   (vars '()))
+               (for-each (lambda (name)
+                           ;; STklos does not recognize macro names, but we can
+                           ;; tell that, if it is exported, and does not have 
a value,
+                           ;; then it is syntax!
+                           (let ((obj (symbol-value name module 
:geiser-stklos--it-is-syntax)))
+                             (cond ((procedure? obj)
+                                    (push! (list name) procs))
+                                   ((eq? obj :geiser-stklos--it-is-syntax)
+                                    (push! (list name) syntaxes))
+                                   (else
+                                    (push! (list name) vars)))))
+                         exports)
+               `(list ("modules") ("procs" . ,procs) ("syntax" . ,syntaxes) 
("vars" . ,vars))))))
+        (else '())))
+
+
+;; returns the documentation for a symbol
+(define (geiser:symbol-documentation name)
+  (with-output-to-string
+    (lambda () (help (eval (eval name))))))
+
+;; used for autodoc. returns the documentation for a symbol.
+(define (geiser:autodoc names . rest)
+  (cond ((null? names) '())
+        ((not (list? names))
+         (geiser:autodoc (list names)))
+        ((symbol? (car names))
+         (with-output-to-string
+           (lambda () (help (car names)))))
+        (else "")))
+
+;; The no-values identity
+(define (geiser:no-values)
+    (values))
+
+(define geiser-stklos-load-paths (make-parameter '("" ".")))
+
+(define (geiser-find-file file . rest)
+  (when file
+    (let ((paths (geiser-stklos-load-paths)))
+      (define (try-find file paths)
+        (cond
+         ((null? paths) #f)
+         ((file-exists? (string-append (car paths) file))
+          (string-append (car paths) file))
+         (else (try-find file (cdr paths)))))
+      (try-find file paths))))
+
+(define (geiser-add-to-load-path directory . rest)
+  (let* ((directory (if (symbol? directory)
+                        (symbol->string directory)
+                        directory))
+         (directory (if (not (equal? #\/ (string-ref directory (- 
(string-length directory)))))
+                        (string-append directory "/")
+                        directory)))
+    (call-with-result
+     (lambda ()
+       (when (directory-exists? directory)
+         (geiser-stklos-load-paths (cons directory 
(geiser-stklos-load-paths))))))))
+
+(define (geiser-compile-file file . rest)
+  #f)
+
+(define (geiser-compile form module . rest)
+  (error "STklos does not support compiling regions"))