branch: elpa/geiser-stklos
commit fc33f459d8a396b09771b5f9e1b09ee6b46253b6
Author: Jeronimo Pellegrini <j...@aleph0.info>
Commit: Jeronimo Pellegrini <j...@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...@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...@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"))
