1 ;; geiser-racket.el -- geiser support for Racket scheme
3 ;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 Jose Antonio Ortega Ruiz
5 ;; This program is free software; you can redistribute it and/or
6 ;; modify it under the terms of the Modified BSD License. You should
7 ;; have received a copy of the license along with this program. If
8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
10 ;; Start date: Sat Apr 25, 2009 21:13
14 (require 'geiser-edit
)
16 (require 'geiser-eval
)
17 (require 'geiser-image
)
18 (require 'geiser-syntax
)
19 (require 'geiser-custom
)
20 (require 'geiser-base
)
25 (eval-when-compile (require 'cl
))
30 (defgroup geiser-racket nil
31 "Customization for Geiser's Racket flavour."
34 (geiser-custom--defcustom geiser-racket-binary
35 (cond ((eq system-type
'windows-nt
) "Racket.exe")
37 "Name to use to call the racket executable when starting a REPL."
38 :type
'(choice string
(repeat string
))
39 :group
'geiser-racket
)
41 (geiser-custom--defcustom geiser-racket-gracket-binary
42 (cond ((eq system-type
'windows-nt
) "GRacket-text.exe")
44 "Name to use to call the gracket executable when starting a REPL.
45 This executable is used by `run-gracket', and, if
46 `geiser-racket-use-gracket-p' is set to t, by `run-racket'."
47 :type
'(choice string
(repeat string
))
48 :group
'geiser-racket
)
50 (geiser-custom--defcustom geiser-racket-collects nil
51 "A list of paths to be added to racket's collection directories."
53 :group
'geiser-racket
)
55 (geiser-custom--defcustom geiser-racket-init-file
"~/.racket-geiser"
56 "Initialization file with user code for the racket REPL."
58 :group
'geiser-racket
)
60 (geiser-custom--defcustom geiser-racket-use-gracket-p nil
61 "Whether to use the gracket binary to start Racket REPLs."
63 :group
'geiser-racket
)
65 (geiser-custom--defcustom geiser-racket-extra-keywords
66 '("provide" "require" "unless" "when" "with-handlers")
67 "Extra keywords highlighted in Racket buffers."
68 :type
'(repeat string
)
69 :group
'geiser-racket
)
71 (geiser-custom--defcustom geiser-racket-case-sensitive-p t
72 "Non-nil means keyword highlighting is case-sensitive."
74 :group
'geiser-racket
)
79 (defsubst geiser-racket--real-binary
()
80 (if geiser-racket-use-gracket-p
81 geiser-racket-gracket-binary
82 geiser-racket-binary
))
84 (defun geiser-racket--binary ()
85 (let ((binary (geiser-racket--real-binary)))
86 (if (listp binary
) (car binary
) binary
)))
88 (defun geiser-racket--parameters ()
89 "Return a list with all parameters needed to start racket.
90 This function uses `geiser-racket-init-file' if it exists."
91 (let ((init-file (and (stringp geiser-racket-init-file
)
92 (expand-file-name geiser-racket-init-file
)))
93 (binary (geiser-racket--real-binary))
94 (rackdir (expand-file-name "racket/" geiser-scheme-dir
)))
95 `("-i" "-q" "-S" ,rackdir
96 ,@(apply 'append
(mapcar (lambda (p) (list "-S" p
))
97 geiser-racket-collects
))
98 ,@(and (listp binary
) (cdr binary
))
99 ,@(and init-file
(file-readable-p init-file
) (list "-f" init-file
))
100 "-f" ,(expand-file-name "geiser/startup.rkt" rackdir
))))
102 (defconst geiser-racket--prompt-regexp
"\\(mzscheme\\|racket\\)@[^ ]*> ")
107 (defun connect-to-racket ()
108 "Start a Racket REPL connected to a remote process.
110 The remote process needs to be running a REPL server started
111 using start-geiser, a procedure in the geiser/server module."
113 (geiser-connect 'racket
))
117 ;;; Evaluation support:
119 (defconst geiser-racket--module-re
120 "^(module[+*]? +\\([^ ]+\\)\\W+\\([^ ]+\\)?")
122 (defun geiser-racket--explicit-module ()
124 (geiser-syntax--pop-to-top)
125 (and (looking-at geiser-racket--module-re
)
126 (let ((mod (match-string-no-properties 1))
127 (lang (match-string-no-properties 2)))
128 (cons (geiser-syntax--form-from-string mod
)
129 (geiser-syntax--form-from-string lang
))))))
131 (defun geiser-racket--language ()
132 (or (cdr (geiser-racket--explicit-module))
134 (goto-char (point-min))
135 (if (re-search-forward "^#lang +\\([^ ]+\\)" nil t
)
136 (geiser-syntax--form-from-string (match-string-no-properties 1))))
139 (defun geiser-racket--implicit-module (&optional pos
)
141 (goto-char (point-min))
142 (when (re-search-forward "^#lang " nil t
)
143 (if pos
(progn (end-of-line) (list (point))) (buffer-file-name)))))
145 (defun geiser-racket--eval-bounds ()
146 (geiser-racket--implicit-module t
))
148 (defun geiser-racket--find-module ()
149 (let ((bf (geiser-racket--implicit-module))
150 (sub (car (geiser-racket--explicit-module))))
151 (cond ((and (not bf
) (not sub
)) nil
)
152 ((and (not bf
) sub
) sub
)
153 (sub `(submod (file ,bf
) ,sub
))
156 (defun geiser-racket--enter-command (module)
157 (when (or (stringp module
) (listp module
))
158 (cond ((zerop (length module
)) ",enter #f")
160 (file-name-absolute-p module
)) (format ",enter %S" module
))
161 (t (format ",enter %s" module
)))))
163 (defun geiser-racket--geiser-procedure (proc &rest args
)
166 (format ",geiser-eval %s %s %s"
168 (geiser-racket--language)
169 (mapconcat 'identity
(cdr args
) " ")))
170 ((load-file compile-file
)
171 (format ",geiser-load %S" (geiser-racket--find-module)))
172 ((no-values) ",geiser-no-values")
173 (t (format ",apply geiser:%s (%s)" proc
(mapconcat 'identity args
" ")))))
175 (defun geiser-racket--get-module (&optional module
)
176 (cond ((null module
) (or (geiser-racket--find-module) :f
))
177 ((symbolp module
) module
)
178 ((and (stringp module
) (file-name-absolute-p module
)) module
)
179 ((stringp module
) (make-symbol module
))
182 (defun geiser-racket--symbol-begin (module)
183 (save-excursion (skip-syntax-backward "^'-()>") (point)))
185 (defun geiser-racket--import-command (module)
186 (and (stringp module
)
187 (not (zerop (length module
)))
188 (format "(require %s)" module
)))
190 (defun geiser-racket--exit-command ()
192 (get-buffer-process (current-buffer)))
194 (defconst geiser-racket--binding-forms
195 '("for" "for/list" "for/hash" "for/hasheq" "for/and" "for/or"
196 "for/lists" "for/first" "for/last" "for/fold"
197 "for:" "for/list:" "for/hash:" "for/hasheq:" "for/and:" "for/or:"
198 "for/lists:" "for/first:" "for/last:" "for/fold:"
199 "define-syntax-rule"))
201 (defconst geiser-racket--binding-forms
*
202 '("for*" "for*/list" "for*/lists" "for*/hash" "for*/hasheq" "for*/and"
203 "for*/or" "for*/first" "for*/last" "for*/fold"
204 "for*:" "for*/list:" "for*/lists:" "for*/hash:" "for*/hasheq:" "for*/and:"
205 "for*/or:" "for*/first:" "for*/last:" "for*/fold:"))
209 (defsubst geiser-racket--get-help
(symbol module
)
210 (geiser-eval--send/wait
`(:scm
,(format ",help %s %s" symbol module
))))
212 (defun geiser-racket--external-help (id module
)
213 (message "Looking up manual for '%s'..." id
)
214 (let* ((ret (geiser-racket--get-help id
(format "%S" module
)))
215 (out (geiser-eval--retort-output ret
))
216 (ret (if (and out
(string-match " but provided by:\n +\\(.+\\)\n" out
))
217 (geiser-racket--get-help id
(match-string 1 out
))
219 (unless (string-match "^Sending to web browser.+"
220 (geiser-eval--retort-output ret
))
221 (minibuffer-message "%s not found" (current-message)))
227 (defconst geiser-racket--file-rxs
229 "path:\"?\\([^>\"\n]+\\)\"?>"
230 "module: \"\\([^>\"\n]+\\)\""))
232 (defconst geiser-racket--geiser-file-rx
233 (format "^ *%s/?racket/geiser" (regexp-quote geiser-scheme-dir
)))
235 (defun geiser-racket--purge-trace ()
237 (while (re-search-forward geiser-racket--geiser-file-rx nil t
)
240 (defun geiser-racket--display-error (module key msg
)
243 (geiser-doc--insert-button key nil
'racket
)
250 (when key
(geiser-racket--purge-trace))
251 (mapc 'geiser-edit--buttonize-files geiser-racket--file-rxs
)
254 (if (and msg
(string-match "\\(.+\\)$" msg
)) (match-string 1 msg
) key
))
257 ;;; Trying to ascertain whether a buffer is racket code:
259 (defun geiser-racket--guess ()
261 (goto-char (point-min))
262 (re-search-forward "#lang " nil t
))
263 (geiser-racket--explicit-module)))
266 ;;; Keywords and syntax
268 (defvar geiser-racket-font-lock-forms
270 ("\\[\\(else\\)\\>" .
1)
271 ("(\\(define/match\\)\\W+[[(]?\\(\\w+\\)+\\b"
272 (1 font-lock-keyword-face
)
273 (2 font-lock-function-name-face
))))
275 (defun geiser-racket--keywords ()
276 (append geiser-racket-font-lock-forms
277 (geiser-syntax--simple-keywords geiser-racket-extra-keywords
)))
279 (geiser-syntax--scheme-indent
283 (compound-unit/sig
0)
338 (parameterize-break 1)
342 (splicing-let-syntax 1)
343 (splicing-let-syntaxes 1)
344 (splicing-let-values 1)
346 (splicing-letrec-syntax 1)
347 (splicing-letrec-syntaxes 1)
348 (splicing-letrec-syntaxes+values
1)
349 (splicing-letrec-values 1)
353 (syntax-id-rules defun
)
364 (defvar geiser-racket-minimum-version
"5.3")
366 (defun geiser-racket--version (binary)
367 (car (process-lines binary
"-e" "(display (version))")))
369 (defvar geiser-racket--image-cache-dir nil
)
371 (defun geiser-racket--startup (remote)
372 (set (make-local-variable 'compilation-error-regexp-alist
)
373 `(("^ *\\([^:(\t\n]+\\):\\([0-9]+\\):\\([0-9]+\\):" 1 2 3)))
374 (compilation-setup t
)
375 (if geiser-image-cache-dir
376 (geiser-eval--send/wait
377 `(:eval
(image-cache ,geiser-image-cache-dir
) geiser
/user
))
378 (setq geiser-racket--image-cache-dir
379 (geiser-eval--send/result
'(:eval
(image-cache) geiser
/user
)))))
381 (defun geiser-racket--image-cache-dir ()
382 (or geiser-image-cache-dir geiser-racket--image-cache-dir
))
385 ;;; Additional commands
387 (defvar geiser-racket--submodule-history
())
389 (defun geiser-racket--submodule-form (name)
390 (format "module[+*]? %s"
391 (cond ((eq 1 name
) "")
393 (read-string "Submodule name: " nil
394 'geiser-racket--submodule-history
))
395 ((stringp name
) name
)
398 (defun geiser-racket-toggle-submodules (&optional name
)
399 "Toggle visibility of submodule forms.
401 Use a prefix to be asked for a submodule name."
403 (geiser-edit--toggle-visibility (geiser-racket--submodule-form name
)))
405 (defun geiser-racket-show-submodules (&optional name
)
406 "Unconditionally shows all submodule forms.
408 Use a prefix to be asked for a submodule name."
410 (cond ((eq 1 name
) (geiser-edit--show-all))
411 (t (geiser-edit--show (geiser-racket--submodule-form name
)))))
413 (defun geiser-racket-hide-submodules (&optional name
)
414 "Unconditionally hides all visible submodules.
416 Use a prefix to be asked for a submodule name."
418 (geiser-edit--hide (geiser-racket--submodule-form name
)))
421 ;;; Implementation definition:
423 (define-geiser-implementation racket
424 (unsupported-procedures '(callers callees generic-methods
))
425 (binary geiser-racket--binary
)
426 (minimum-version geiser-racket-minimum-version
)
427 (version-command geiser-racket--version
)
428 (arglist geiser-racket--parameters
)
429 (repl-startup geiser-racket--startup
)
430 (prompt-regexp geiser-racket--prompt-regexp
)
431 (marshall-procedure geiser-racket--geiser-procedure
)
432 (find-module geiser-racket--get-module
)
433 (enter-command geiser-racket--enter-command
)
434 (import-command geiser-racket--import-command
)
435 (exit-command geiser-racket--exit-command
)
436 (find-symbol-begin geiser-racket--symbol-begin
)
437 (eval-bounds geiser-racket--eval-bounds
)
438 (display-error geiser-racket--display-error
)
439 (external-help geiser-racket--external-help
)
440 (check-buffer geiser-racket--guess
)
441 (keywords geiser-racket--keywords
)
442 (image-cache-dir geiser-racket--image-cache-dir
)
443 (case-sensitive geiser-racket-case-sensitive-p
)
444 (binding-forms geiser-racket--binding-forms
)
445 (binding-forms* geiser-racket--binding-forms
*))
447 (geiser-impl--add-to-alist 'regexp
"\\.ss$" 'racket t
)
448 (geiser-impl--add-to-alist 'regexp
"\\.rkt$" 'racket t
)
450 (defun run-gracket ()
451 "Start the Racket REPL using gracket instead of plain racket."
453 (let ((geiser-racket-use-gracket-p t
))
457 (provide 'geiser-racket
)