[nongnu] elpa/geiser-racket 7a62da17 181/191: Import elisp/geiser-racket.el from original repo

[Philip Kaludercic]

branch: elpa/geiser-racket
commit 7a62da17b97052697f7f462f95393992ea49d990
Merge: 8dbb75c 88cc6d9
Author: jao <jao@gnu.org>
Commit: jao <jao@gnu.org>

    Import elisp/geiser-racket.el from original repo
---
 elisp/geiser-racket.el | 458 +++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 458 insertions(+)

diff --git a/elisp/geiser-racket.el b/elisp/geiser-racket.el
new file mode 100644
index 0000000..6d17bb7
--- /dev/null
+++ b/elisp/geiser-racket.el
@@ -0,0 +1,458 @@
+;;; geiser-racket.el -- geiser support for Racket scheme
+
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 Jose Antonio 
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: Sat Apr 25, 2009 21:13
+
+
+;;; Code:
+
+(require 'geiser-edit)
+(require 'geiser-doc)
+(require 'geiser-eval)
+(require 'geiser-image)
+(require 'geiser-syntax)
+(require 'geiser-custom)
+(require 'geiser-base)
+(require 'geiser)
+
+(require 'compile)
+
+(eval-when-compile (require 'cl-lib))
+
+
+;;; Customization:
+
+(defgroup geiser-racket nil
+  "Customization for Geiser's Racket flavour."
+  :group 'geiser)
+
+(geiser-custom--defcustom geiser-racket-binary
+    (cond ((eq system-type 'windows-nt) "Racket.exe")
+          (t "racket"))
+  "Name to use to call the racket executable when starting a REPL."
+  :type '(choice string (repeat string))
+  :group 'geiser-racket)
+
+(geiser-custom--defcustom geiser-racket-gracket-binary
+    (cond ((eq system-type 'windows-nt) "GRacket-text.exe")
+          (t "gracket-text"))
+  "Name to use to call the gracket executable when starting a REPL.
+This executable is used by `run-gracket', and, if
+`geiser-racket-use-gracket-p' is set to t, by `run-racket'."
+  :type '(choice string (repeat string))
+  :group 'geiser-racket)
+
+(geiser-custom--defcustom geiser-racket-collects nil
+  "A list of paths to be added to racket's collection directories."
+  :type '(repeat file)
+  :group 'geiser-racket)
+
+(geiser-custom--defcustom geiser-racket-init-file "~/.racket-geiser"
+  "Initialization file with user code for the racket REPL."
+  :type 'string
+  :group 'geiser-racket)
+
+(geiser-custom--defcustom geiser-racket-use-gracket-p nil
+  "Whether to use the gracket binary to start Racket REPLs."
+  :type 'boolean
+  :group 'geiser-racket)
+
+(geiser-custom--defcustom geiser-racket-extra-keywords
+    '("provide" "require" "unless" "when" "with-handlers")
+  "Extra keywords highlighted in Racket buffers."
+  :type '(repeat string)
+  :group 'geiser-racket)
+
+(geiser-custom--defcustom geiser-racket-case-sensitive-p t
+  "Non-nil means keyword highlighting is case-sensitive."
+  :type 'boolean
+  :group 'geiser-racket)
+
+
+;;; REPL support:
+
+(defsubst geiser-racket--real-binary ()
+  (if geiser-racket-use-gracket-p
+      geiser-racket-gracket-binary
+    geiser-racket-binary))
+
+(defun geiser-racket--binary ()
+  (let ((binary (geiser-racket--real-binary)))
+    (if (listp binary) (car binary) binary)))
+
+(defun geiser-racket--parameters ()
+  "Return a list with all parameters needed to start racket.
+This function uses `geiser-racket-init-file' if it exists."
+  (let ((init-file (and (stringp geiser-racket-init-file)
+                        (expand-file-name geiser-racket-init-file)))
+        (binary (geiser-racket--real-binary))
+        (rackdir (expand-file-name "racket/" geiser-scheme-dir)))
+    `("-i" "-q" "-S" ,rackdir
+      ,@(apply 'append (mapcar (lambda (p) (list "-S" p))
+                               geiser-racket-collects))
+      ,@(and (listp binary) (cdr binary))
+      ,@(and init-file (file-readable-p init-file) (list "-f" init-file))
+      "-f" ,(expand-file-name "geiser/startup.rkt" rackdir))))
+
+(defconst geiser-racket--prompt-regexp "\\(mzscheme\\|racket\\)@[^ ]*> ")
+
+
+;;; Remote REPLs
+
+(defun connect-to-racket ()
+  "Start a Racket REPL connected to a remote process.
+
+The remote process needs to be running a REPL server started
+using start-geiser, a procedure in the geiser/server module."
+  (interactive)
+  (geiser-connect 'racket))
+
+
+
+;;; Evaluation support:
+
+(defconst geiser-racket--module-re
+  "^(module[+*]? +\\([^ ]+\\)\\W+\\([^ ]+\\)?")
+
+(defun geiser-racket--explicit-module ()
+  (save-excursion
+    (geiser-syntax--pop-to-top)
+    (and (looking-at geiser-racket--module-re)
+         (let ((mod (match-string-no-properties 1))
+               (lang (match-string-no-properties 2)))
+           (cons (geiser-syntax--form-from-string mod)
+                 (geiser-syntax--form-from-string lang))))))
+
+(defun geiser-racket--language ()
+  (or (cdr (geiser-racket--explicit-module))
+      (save-excursion
+        (goto-char (point-min))
+        (if (re-search-forward "^#lang +\\([^ ]+\\)" nil t)
+            (geiser-syntax--form-from-string (match-string-no-properties 1))))
+      "#f"))
+
+(defun geiser-racket--implicit-module (&optional pos)
+  (save-excursion
+    (goto-char (point-min))
+    (when (re-search-forward "^#lang " nil t)
+      (if pos (progn (end-of-line) (list (point))) (buffer-file-name)))))
+
+(defun geiser-racket--eval-bounds ()
+  (geiser-racket--implicit-module t))
+
+(defun geiser-racket--find-module ()
+  (let ((bf (geiser-racket--implicit-module))
+        (sub (car (geiser-racket--explicit-module))))
+    (cond ((and (not bf) (not sub)) nil)
+          ((and (not bf) sub) sub)
+          (sub `(submod (file ,bf) ,sub))
+          (t bf))))
+
+(defun geiser-racket--enter-command (module)
+  (when (or (stringp module) (listp module))
+    (cond ((zerop (length module)) ",enter #f")
+          ((or (listp module)
+               (file-name-absolute-p module)) (format ",enter %S" module))
+          (t (format ",enter %s" module)))))
+
+(defun geiser-racket--geiser-procedure (proc &rest args)
+  (cl-case proc
+    ((eval compile)
+     (format ",geiser-eval %s %s %s"
+             (or (car args) "#f")
+             (geiser-racket--language)
+             (mapconcat 'identity (cdr args) " ")))
+    ((load-file compile-file)
+     (format ",geiser-load %S" (geiser-racket--find-module)))
+    ((no-values) ",geiser-no-values")
+    (t (format ",apply geiser:%s (%s)" proc (mapconcat 'identity args " ")))))
+
+(defun geiser-racket--get-module (&optional module)
+  (cond ((null module) (or (geiser-racket--find-module) :f))
+        ((symbolp module) module)
+        ((and (stringp module) (file-name-absolute-p module)) module)
+        ((stringp module) (make-symbol module))
+        (t nil)))
+
+(defun geiser-racket--symbol-begin (module)
+  (save-excursion (skip-syntax-backward "^'-()>") (point)))
+
+(defun geiser-racket--import-command (module)
+  (and (stringp module)
+       (not (zerop (length module)))
+       (format "(require %s)" module)))
+
+(defun geiser-racket--exit-command ()
+  (comint-send-eof)
+  (get-buffer-process (current-buffer)))
+
+(defconst geiser-racket--binding-forms
+  '("for" "for/list" "for/hash" "for/hasheq" "for/and" "for/or"
+    "for/lists" "for/first" "for/last" "for/fold"
+    "for:" "for/list:" "for/hash:" "for/hasheq:" "for/and:" "for/or:"
+    "for/lists:" "for/first:" "for/last:" "for/fold:"
+    "define-syntax-rule"))
+
+(defconst geiser-racket--binding-forms*
+  '("for*" "for*/list" "for*/lists" "for*/hash" "for*/hasheq" "for*/and"
+    "for*/or" "for*/first" "for*/last" "for*/fold"
+    "for*:" "for*/list:" "for*/lists:" "for*/hash:" "for*/hasheq:" "for*/and:"
+    "for*/or:" "for*/first:" "for*/last:" "for*/fold:"))
+
+;;; External help
+
+(defsubst geiser-racket--get-help (symbol module)
+  (geiser-eval--send/wait `(:scm ,(format ",help %s %s" symbol module))))
+
+(defun geiser-racket--external-help (id module)
+  (message "Looking up manual for '%s'..." id)
+  (let* ((ret (geiser-racket--get-help id (format "%S" module)))
+         (out (geiser-eval--retort-output ret))
+         (ret (if (and out (string-match " but provided by:\n +\\(.+\\)\n" 
out))
+                  (geiser-racket--get-help id (match-string 1 out))
+                ret)))
+    (unless (string-match "^Sending to web browser.+"
+                          (geiser-eval--retort-output ret))
+      (minibuffer-message "%s not found" (current-message)))
+    t))
+
+
+;;; Error display
+
+(defconst geiser-racket--file-rxs
+  '(nil
+    "path:\"?\\([^>\"\n]+\\)\"?>"
+    "module: \"\\([^>\"\n]+\\)\""))
+
+(defconst geiser-racket--geiser-file-rx
+  (format "^ *%s/?racket/geiser" (regexp-quote geiser-scheme-dir)))
+
+(defun geiser-racket--purge-trace ()
+  (save-excursion
+    (while (re-search-forward geiser-racket--geiser-file-rx nil t)
+      (kill-whole-line))))
+
+(defun geiser-racket--display-error (module key msg)
+  (when key
+    (insert "Error: ")
+    (geiser-doc--insert-button key nil 'racket)
+    (newline 2))
+  (when msg
+    (let ((p (point)))
+      (insert msg)
+      (let ((end (point)))
+        (goto-char p)
+        (when key (geiser-racket--purge-trace))
+        (mapc 'geiser-edit--buttonize-files geiser-racket--file-rxs)
+        (goto-char end)
+        (newline))))
+  (if (and msg (string-match "\\(.+\\)$" msg)) (match-string 1 msg) key))
+
+
+;;; Trying to ascertain whether a buffer is racket code:
+
+(defun geiser-racket--guess ()
+  (or (save-excursion
+        (goto-char (point-min))
+        (re-search-forward "#lang " nil t))
+      (geiser-racket--explicit-module)))
+
+
+;;; Keywords and syntax
+
+(defvar geiser-racket-font-lock-forms
+  '(("^#lang\\>" . 0)
+    ("\\[\\(else\\)\\>" . 1)
+    ("(\\(define/match\\)\\W+[[(]?\\(\\w+\\)+\\b"
+     (1 font-lock-keyword-face)
+     (2 font-lock-function-name-face))))
+
+(defun geiser-racket--keywords ()
+  (append geiser-racket-font-lock-forms
+          (geiser-syntax--simple-keywords geiser-racket-extra-keywords)))
+
+(geiser-syntax--scheme-indent
+ (begin0 1)
+ (case-lambda: 0)
+ (class* defun)
+ (compound-unit/sig 0)
+ (define: defun)
+ (for 1)
+ (for* 1)
+ (for*/and 1)
+ (for*/first 1)
+ (for*/fold 2)
+ (for*/hash 1)
+ (for*/hasheq 1)
+ (for*/hasheqv 1)
+ (for*/last 1)
+ (for*/list 1)
+ (for*/lists 2)
+ (for*/or 1)
+ (for*/product 1)
+ (for*/set 1)
+ (for*/seteq 1)
+ (for*/seteqv 1)
+ (for*/sum 1)
+ (for*/vector 1)
+ (for/and 1)
+ (for/first 1)
+ (for/fold 2)
+ (for/hash 1)
+ (for/hasheq 1)
+ (for/hasheqv 1)
+ (for/last 1)
+ (for/list 1)
+ (for/lists 2)
+ (for/or 1)
+ (for/product 1)
+ (for/set 1)
+ (for/seteq 1)
+ (for/seteqv 1)
+ (for/sum 1)
+ (for/vector 1)
+ (instantiate 2)
+ (interface 1)
+ (lambda/kw 1)
+ (lambda: 1)
+ (let*-values: 1)
+ (let+ 1)
+ (let-values: 1)
+ (let/cc: 1)
+ (let: 1)
+ (letrec-values: 1)
+ (letrec: 1)
+ (local 1)
+ (match-let 1)
+ (match-let-values 1)
+ (match/values 1)
+ (mixin 2)
+ (module defun)
+ (module+ defun)
+ (module* defun)
+ (parameterize-break 1)
+ (quasisyntax/loc 1)
+ (send* 1)
+ (splicing-let 1)
+ (splicing-let-syntax 1)
+ (splicing-let-syntaxes 1)
+ (splicing-let-values 1)
+ (splicing-letrec 1)
+ (splicing-letrec-syntax 1)
+ (splicing-letrec-syntaxes 1)
+ (splicing-letrec-syntaxes+values 1)
+ (splicing-letrec-values 1)
+ (splicing-local 1)
+ (shared 1)
+ (struct 1)
+ (syntax-id-rules defun)
+ (syntax/loc 1)
+ (type-case defun)
+ (unit defun)
+ (unit/sig 2)
+ (with-handlers 1)
+ (with-handlers: 1))
+
+
+;;; REPL Startup
+
+(defvar geiser-racket-minimum-version "5.3")
+
+(defun geiser-racket--version (binary)
+  (car (process-lines binary "-e" "(display (version))")))
+
+(defvar geiser-racket--image-cache-dir nil)
+
+(defun geiser-racket--startup (remote)
+  (set (make-local-variable 'compilation-error-regexp-alist)
+       `(("^ *\\([^:(\t\n]+\\):\\([0-9]+\\):\\([0-9]+\\):" 1 2 3)))
+  (compilation-setup t)
+  (if geiser-image-cache-dir
+      (geiser-eval--send/wait
+       `(:eval (image-cache ,geiser-image-cache-dir) geiser/user))
+    (setq geiser-racket--image-cache-dir
+          (geiser-eval--send/result '(:eval (image-cache) geiser/user)))))
+
+(defun geiser-racket--image-cache-dir ()
+  (or geiser-image-cache-dir geiser-racket--image-cache-dir))
+
+
+;;; Additional commands
+
+(defvar geiser-racket--submodule-history ())
+
+(defun geiser-racket--submodule-form (name)
+  (format "module[+*]? %s"
+          (cond ((eq 1 name) "")
+                ((numberp name)
+                 (read-string "Submodule name: " nil
+                              'geiser-racket--submodule-history))
+                ((stringp name) name)
+                (t ""))))
+
+(defun geiser-racket-toggle-submodules (&optional name)
+  "Toggle visibility of submodule forms.
+
+Use a prefix to be asked for a submodule name."
+  (interactive "p")
+  (geiser-edit--toggle-visibility (geiser-racket--submodule-form name)))
+
+(defun geiser-racket-show-submodules (&optional name)
+  "Unconditionally shows all submodule forms.
+
+Use a prefix to be asked for a submodule name."
+  (interactive "p")
+  (cond ((eq 1 name) (geiser-edit--show-all))
+        (t (geiser-edit--show (geiser-racket--submodule-form name)))))
+
+(defun geiser-racket-hide-submodules (&optional name)
+  "Unconditionally hides all visible submodules.
+
+Use a prefix to be asked for a submodule name."
+  (interactive "p")
+  (geiser-edit--hide (geiser-racket--submodule-form name)))
+
+
+;;; Implementation definition:
+
+(define-geiser-implementation racket
+  (unsupported-procedures '(callers callees generic-methods))
+  (binary geiser-racket--binary)
+  (minimum-version geiser-racket-minimum-version)
+  (version-command geiser-racket--version)
+  (arglist geiser-racket--parameters)
+  (repl-startup geiser-racket--startup)
+  (prompt-regexp geiser-racket--prompt-regexp)
+  (marshall-procedure geiser-racket--geiser-procedure)
+  (find-module geiser-racket--get-module)
+  (enter-command geiser-racket--enter-command)
+  (import-command geiser-racket--import-command)
+  (exit-command geiser-racket--exit-command)
+  (find-symbol-begin geiser-racket--symbol-begin)
+  (eval-bounds geiser-racket--eval-bounds)
+  (display-error geiser-racket--display-error)
+  (external-help geiser-racket--external-help)
+  (check-buffer geiser-racket--guess)
+  (keywords geiser-racket--keywords)
+  (image-cache-dir geiser-racket--image-cache-dir)
+  (case-sensitive geiser-racket-case-sensitive-p)
+  (binding-forms geiser-racket--binding-forms)
+  (binding-forms* geiser-racket--binding-forms*))
+
+(geiser-impl--add-to-alist 'regexp "\\.ss$" 'racket t)
+(geiser-impl--add-to-alist 'regexp "\\.rkt[dl]?$" 'racket t)
+
+(defun run-gracket ()
+  "Start the Racket REPL using gracket instead of plain racket."
+  (interactive)
+  (let ((geiser-racket-use-gracket-p t))
+    (run-racket)))
+
+
+(provide 'geiser-racket)