[nongnu] elpa/geiser-kawa 4247497 007/119: Add geiser-kawa.el (project is starting to work)

[Philip Kaludercic]

branch: elpa/geiser-kawa
commit 42474970c14bf882f438c877cec17b63b711d4ce
Author: spellcard199 <spellcard199@protonmail.com>
Commit: spellcard199 <spellcard199@protonmail.com>

    Add geiser-kawa.el (project is starting to work)
---
 elisp/geiser-kawa.el | 393 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 393 insertions(+)

diff --git a/elisp/geiser-kawa.el b/elisp/geiser-kawa.el
new file mode 100644
index 0000000..63e2580
--- /dev/null
+++ b/elisp/geiser-kawa.el
@@ -0,0 +1,393 @@
+;;; geiser-kawa.el --- geiser support for Kawa scheme -*- lexical-binding:t -*-
+
+;; Copyright (C) 2018 Mathieu Lirzin <mthl@gnu.org>
+;; Copyright (C) 2019 spellcard199 <spellcard199@protonmail.com>
+
+;; 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>.
+
+;; Author: spellcard199 <spellcard199@protonmail.com>
+;; Maintainer: spellcard199 <spellcard199@protonmail.com>
+;; Keywords: languages, kawa, scheme, geiser
+;; Homepage: https://gitlab.com/spellcard199/geiser-kawa
+;; Package-Requires: ((emacs "26.1") (geiser "20191025.650"))
+;; Version: 0.0.1
+
+;; This file is NOT part of GNU Emacs.
+
+;;; Commentary:
+
+;; geiser-kawa extends the `geiser' package to support the Kawa
+;; scheme implementation.
+
+
+(require 'geiser-base)
+(require 'geiser-custom)
+(require 'geiser-syntax)
+(require 'geiser-log)
+(require 'geiser-connection)
+(require 'geiser-eval)
+(require 'geiser-edit)
+(require 'geiser)
+
+(require 'compile)
+(require 'info-look)
+(require 'cl)
+
+;;; Code:
+
+
+;; Adaptations for making this package separate from geiser
+
+;; Adapted from geiser.el
+;;;###autoload
+(defconst geiser-kawa-elisp-dir
+  (file-name-directory (or load-file-name (buffer-file-name)))
+  "Directory containing geiser-kawa's Elisp files.")
+
+;; Adapted from geiser.el
+;;;###autoload
+(defconst geiser-kawa-dir
+  (if (string-suffix-p "elisp/" geiser-kawa-elisp-dir)
+      (expand-file-name "../" geiser-kawa-elisp-dir)
+    geiser-kawa-elisp-dir)
+  "geiser-kawa's directory.")
+
+;; Adapted from geiser.el
+(custom-add-load 'geiser-kawa (symbol-name 'geiser-kawa))
+(custom-add-load 'geiser      (symbol-name 'geiser-kawa))
+
+;; Moved from geiser.el
+;;;###autoload
+(autoload 'run-kawa "geiser-kawa" "Start a Geiser Kawa Scheme REPL." t)
+
+;;;###autoload
+(autoload 'switch-to-kawa "geiser-kawa"
+  "Start a Geiser Kawa Scheme REPL, or switch to a running one." t)
+
+;; `geiser-active-implementations' is defined in `geiser-impl.el'
+(add-to-list 'geiser-active-implementations 'kawa)
+
+;; End of adaptations for making this package separate from geiser
+
+
+;; Compile the included "kawa-geiser" maven project into a fat jar
+(defun geiser-kawa-compile-java-dependencies()
+  (interactive)
+  (let ((default-directory geiser-kawa-dir))
+    (compile "mvn package")))
+
+;; Using `mvn package' from the pom.xml's directory should produce a
+;; jar containing all the java dependencies.
+(defcustom geiser-kawa-kawa-geiser-jar-path
+  (expand-file-name
+   "./target/kawa-geiser-wrapper-0.1-SNAPSHOT-jar-with-dependencies.jar"
+   geiser-kawa-dir)
+  "Path to the kawa-geiser fat jar."
+  :type 'string
+  :group 'geiser-kawa)
+
+
+;;; Customization:
+
+(defgroup geiser-kawa nil
+  "Customization for Geiser's Kawa Scheme flavour."
+  :group 'geiser)
+
+(geiser-custom--defcustom
+    geiser-kawa-binary "kawa"
+  "Name to use to call the Kawa Scheme executable when starting a REPL."
+  :type '(choice string (repeat string))
+  :group 'geiser-kawa)
+
+;; TODO: replace file-name-directory/directory-file-name with expand-file-name
+(geiser-custom--defcustom
+    geiser-kawa-manual-path
+    (concat
+     (file-name-directory
+      (directory-file-name
+       (file-name-directory
+        (directory-file-name
+         (executable-find geiser-kawa-binary)))))
+     "doc/kawa-manual.epub")
+  "Path of kawa manual. Supported formats are `.epub' (using
+`eww-mode') and `.info' (using `info.el')."
+  :type 'string
+  :group 'geiser-kawa)
+
+(defcustom geiser-kawa-use-kawa-version-included-in-kawa-geiser
+  nil
+  "Instead of downloading kawa yourself, you can use the Kawa version
+ included in geiser-kawa, which is the head of Kawa's master branch."
+  :type 'boolean
+  :group 'geiser-kawa)
+
+
+;;; REPL support:
+
+(defun geiser-kawa--binary ()
+  ". If `geiser-kawa-binary' is a list, take the first and ignore
+ `geiser-kawa-use-kawa-version-included-in-kawa-geiser'."
+  (if geiser-kawa-use-kawa-version-included-in-kawa-geiser
+      "java"
+    (if (listp geiser-kawa-binary)
+        (car geiser-kawa-binary)
+      geiser-kawa-binary)))
+
+(defun geiser-kawa--make-classpath ()
+  (let ((jars (append
+               (let ((lib-dir (expand-file-name
+                               "../lib/"
+                               (file-name-directory
+                                (executable-find geiser-kawa-binary)))))
+                 (if (and
+                      (not 
geiser-kawa-use-kawa-version-included-in-kawa-geiser)
+                      (executable-find geiser-kawa-binary)
+                      (file-directory-p lib-dir))
+                     (list
+                      (concat lib-dir "kawa.jar")
+                      (concat lib-dir "servlet.jar")
+                      (concat lib-dir "domterm.jar")
+                      (concat lib-dir "jline.jar"))
+                   nil))
+               (list geiser-kawa-kawa-geiser-jar-path))))
+    (mapconcat #'identity jars ":")))
+
+(defvar geiser-kawa--arglist
+  `(;; jline "invisibly" echoes user input and prints ansi chars that
+    ;; makes harder detecting end of output and finding the correct
+    ;; prompt regexp.
+    "console:use-jline=no"
+    "-e"
+    "(require <kawageiser.Geiser>)"
+    "--"))
+
+(defun geiser-kawa--parameters ()
+  "Return a list with all parameters needed to start Kawa Scheme."
+  (append
+   (list (format "-Djava.class.path=%s" (geiser-kawa--make-classpath)))
+   (if geiser-kawa-use-kawa-version-included-in-kawa-geiser
+       (list "kawa.repl"))
+   geiser-kawa--arglist))
+
+(defconst geiser-kawa--prompt-regexp
+  "#|kawa:[0-9]+|# ")
+
+(defun geiser-kawa--geiser-procedure (proc &rest args)
+
+  (case proc
+    ((eval compile)
+     (let* ((form (mapconcat 'identity args " ")) ;;unused
+            (send-this
+             (format
+              "(geiser:eval (interaction-environment) %S)"
+              (cadr args))))
+       send-this))
+
+    ((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)))))
+
+;; TODO
+;; (defun geiser-kawa--find-module (&optional module))
+
+;; Doesn't work:
+;; (defun geiser-kawa--symbol-begin (module)
+;;  (save-excursion (skip-syntax-backward "^|#") (point)))
+;; TODO: see if it needs improvements.
+(defun geiser-kawa--symbol-begin (module)
+  ;; Needed for completion. Copied from geiser-chibi.el,
+  ;; geiser-guile.el, which are identical to each other.
+  (if module
+      (max (save-excursion (beginning-of-line) (point))
+           (save-excursion (skip-syntax-backward "^(>") (1- (point))))
+    (save-excursion (skip-syntax-backward "^'-()>") (point))))
+
+(defun geiser-kawa--import-command (module)
+  (format "(import %s)" module))
+
+(defun geiser-kawa--exit-command ()
+  "(exit 0)")
+
+
+;;; REPL startup
+
+(defun geiser-kawa--version-command (binary)
+  (let ((prog+vers (car (process-lines binary "--version"))))
+    (cadr (split-string prog+vers " "))))
+
+(defun geiser-kawa--repl-startup (remote)
+  (let ((geiser-log-verbose-p t))
+    (compilation-setup t)))
+
+
+;;; Error display
+
+;; TODO
+(defun geiser-kawa--enter-debugger ())
+
+(defun geiser-kawa--display-error (module key msg)
+  ;; Needed to show output (besides result). Modified from
+  ;; geiser-guile.el.
+  (when (stringp msg)
+    (save-excursion (insert msg))
+    (geiser-edit--buttonize-files))
+  (and (not key) (not (zerop (length msg))) msg))
+
+
+;;; Manual lookup
+
+;;;; Support for manual in .epub format
+
+;; FIXME: port old scheme logic to java
+(cl-defun geiser-kawa--manual-epub-unzip-to-tmpdir
+    (&optional (epub-path geiser-kawa--manual))
+  "Unzip the .epub file with kawa/java, since:
+- kawa is already a dependency
+- kawa/java is more portable that using emacs' arc-mode, which relies
+  on external executables installed"
+  (with-temp-buffer
+    (with--geiser-implementation
+        'kawa
+      (geiser-eval--send/result
+       (format
+        "(geiser:eval (interaction-environment) %S)"
+        (format "(geiser:manual-epub-unzip-to-tmp-dir %S)"
+                epub-path))))))
+
+(defvar geiser-kawa--manual-epub-cached-overall-index
+  nil
+  "Since `eww-open-file' is slow we use it just the first time.
+Then we cache the result in this variable so that future lookups in
+the manual are more responsive.")
+
+(cl-defun geiser-kawa--manual-epub-search
+    (needle &optional (epub-path geiser-kawa-manual-path))
+  ;; Validate args
+  (assert (stringp needle) nil (type-of needle))
+  (assert (stringp epub-path) nil (type-of epub-path))
+  (assert (string-suffix-p ".epub" epub-path) nil epub-path)
+  (assert (file-exists-p epub-path) nil epub-path)
+
+  (with-current-buffer (get-buffer-create
+                        " *geiser-kawa-epub-manual*")
+    (eww-mode)
+    (if geiser-kawa--manual-epub-cached-overall-index
+        (progn
+          (read-only-mode -1)
+          (delete-region (point-min) (point-max))
+          (insert geiser-kawa--manual-epub-cached-overall-index))
+      (let* ((unzipped-epub-dir
+              ;; Ask kawa to unzip epub: more portable than unzipping
+              ;; with emacs' `arc-mode'.
+              (geiser-kawa--manual-epub-unzip-to-tmpdir epub-path))
+             (overall-index-file
+              (format "%s/OEBPS/Overall-Index.xhtml" unzipped-epub-dir))
+             (epub-man-buffer
+              (get-buffer-create "*geiser-kawa-epub-manual*")))
+        (when (not unzipped-epub-dir)
+          (error "Can't open manual: Kawa did not unzip the epub when asked."))
+        (eww-open-file overall-index-file)
+        ;; Store overall index page in a variable to be used as cache.
+        (setq geiser-kawa--manual-epub-cached-overall-index (buffer-string))))
+
+    ;; At this point the Overall Index page should be opened.
+    (goto-char (point-min))
+    (if (search-forward (concat "\n" needle ": ") nil t) ;; Search
+        (progn
+          (backward-char 3) ;; Move point over link
+          (eww-browse-url (car (eww-links-at-point))) ;; Follow link
+          (recenter-top-bottom 'top))
+      (message (format "No match for `%s' found in Kawa's epub manual." 
needle)))))
+
+;;;; Support for manual in .info format
+(cl-defun geiser-kawa--manual-info-search
+    (needle &optional (info-path geiser-kawa-manual-path))
+
+  ;; Validate args
+  (assert (stringp needle) nil (type-of needle))
+  (assert (stringp info-path) nil (type-of info-path))
+  (assert (string-suffix-p ".info" info-path) nil info-path)
+  (assert (file-exists-p info-path) nil info-path)
+
+  (with-current-buffer (get-buffer-create "*geiser-kawa-info-manual*")
+    (info info-path (current-buffer))
+    (Info-goto-node "Overall Index")
+    (if (search-forward (concat "\n* " needle) nil t)
+        (progn
+          (Info-follow-nearest-node)
+          (recenter-top-bottom 'top))
+      (progn
+        (quit-window)
+        (message (format "No match for `%s' found in Kawa's info manual."
+                         needle))))))
+
+;;;; Dispatch to epub or info manual function based on
+;;;; `geiser-kawa-manual-path's file extension.
+(defun geiser-kawa--manual-look-up (id mod)
+  "Use epub or info manual depending on `geiser-kawa-manual-path'.
+
+Argument ID is the symbol to look for in the manual.
+Argument MOD is passed by geiser, but it's not used here."
+  (assert (file-exists-p geiser-kawa-manual-path)
+          nil (format
+               (concat
+                "Kawa's manual file specified by "
+                "`geiser-kawa-manual-path' does not exist: \"%s\"")
+               geiser-kawa-manual-path))
+  (cond
+   ((string-suffix-p ".epub" geiser-kawa-manual-path)
+    (geiser-kawa--manual-epub-search (symbol-name id)
+                                     geiser-kawa-manual-path))
+   ((string-suffix-p ".info" geiser-kawa-manual-path)
+    (geiser-kawa--manual-info-search (symbol-name id)
+                                     geiser-kawa-manual-path))
+   (t (error "Supported formats for `geiser-kawa-manual-path' are only `.epub' 
and `.info'"))))
+
+
+;;; Implementation definition:
+
+(eval
+ ;; (temporary?) Workaround for Cask issue. Wrapping
+ ;; `define-geiser-implementation' with `eval' avoids issue
+ ;; https://github.com/cask/cask/issues/472 in projects that depend on
+ ;; geiser-kawa.
+ '(define-geiser-implementation kawa
+    (unsupported-procedures '(macroexpand
+                              find-file
+                              symbol-location
+                              module-location
+                              symbol-documentation
+                              module-exports
+                              callers
+                              callees
+                              generic-methods))
+    (binary geiser-kawa--binary)
+    (arglist geiser-kawa--parameters)
+    (version-command geiser-kawa--version-command)
+    (repl-startup geiser-kawa--repl-startup)
+    (prompt-regexp geiser-kawa--prompt-regexp)
+    (debugger-prompt-regexp nil)
+    (marshall-procedure geiser-kawa--geiser-procedure)
+    ;; TODO
+    ;; (find-module geiser-kawa--find-module nil)
+    (exit-command geiser-kawa--exit-command)
+    (import-command geiser-kawa--import-command)
+    (find-symbol-begin geiser-kawa--symbol-begin)
+    (display-error geiser-kawa--display-error)
+    (case-sensitive nil)
+    (external-help geiser-kawa--manual-look-up)))
+
+(geiser-impl--add-to-alist 'regexp "\\.scm$" 'kawa t)
+(geiser-impl--add-to-alist 'regexp "\\.sld$" 'kawa t)
+
+(provide 'geiser-kawa)
+
+;;; geiser-kawa.el ends here