1 ;; geiser-guile.el -- guile's implementation of the geiser protocols
3 ;; Copyright (C) 2009-2017 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: Sun Mar 08, 2009 23:03
14 (require 'geiser-connection
)
15 (require 'geiser-syntax
)
16 (require 'geiser-custom
)
17 (require 'geiser-base
)
18 (require 'geiser-eval
)
19 (require 'geiser-edit
)
26 (eval-when-compile (require 'cl
))
31 (defgroup geiser-guile nil
32 "Customization for Geiser's Guile flavour."
35 (geiser-custom--defcustom geiser-guile-binary
36 (cond ((eq system-type
'windows-nt
) "guile.exe")
37 ((eq system-type
'darwin
) "guile")
39 "Name to use to call the Guile executable when starting a REPL."
40 :type
'(choice string
(repeat string
))
43 (geiser-custom--defcustom geiser-guile-load-path nil
44 "A list of paths to be added to Guile's load path when it's started.
45 The paths are added to both %load-path and %load-compiled path,
46 and only if they are not already present. This variable is a
47 good candidate for an entry in your project's .dir-locals.el."
51 (geiser-custom--defcustom geiser-guile-init-file
"~/.guile-geiser"
52 "Initialization file with user code for the Guile REPL.
53 If all you want is to load ~/.guile, set
54 `geiser-guile-load-init-file-p' instead."
58 (geiser-custom--defcustom geiser-guile-load-init-file-p nil
59 "Whether to load ~/.guile when starting Guile.
60 Note that, due to peculiarities in the way Guile loads its init
61 file, using `geiser-guile-init-file' is not equivalent to setting
66 (geiser-custom--defcustom geiser-guile-debug-show-bt-p nil
67 "Whether to autmatically show a full backtrace when entering the debugger.
68 If `nil', only the last frame is shown."
72 (geiser-custom--defcustom geiser-guile-jump-on-debug-p nil
73 "Whether to autmatically jump to error when entering the debugger.
74 If `t', Geiser will use `next-error' to jump to the error's location."
78 (geiser-custom--defcustom geiser-guile-show-debug-help-p t
79 "Whether to show brief help in the echo area when entering the debugger."
83 (geiser-custom--defcustom geiser-guile-warning-level
'medium
84 "Verbosity of the warnings reported by Guile.
86 You can either choose one of the predefined warning sets, or
87 provide a list of symbols identifying the ones you want. Possible
88 choices are arity-mismatch, unbound-variable, unused-variable and
89 unused-toplevel. Unrecognised symbols are ignored.
91 The predefined levels are:
93 - Medium: arity-mismatch, unbound-variable, format
94 - High: arity-mismatch, unbound-variable, unused-variable, format
97 Changes to the value of this variable will automatically take
98 effect on new REPLs. For existing ones, use the command
99 \\[geiser-guile-update-warning-level]."
100 :type
'(choice (const :tag
"Medium (arity and unbound vars)" medium
)
101 (const :tag
"High (also unused vars)" high
)
102 (const :tag
"No warnings" none
)
103 (repeat :tag
"Custom" symbol
))
104 :group
'geiser-guile
)
106 (geiser-custom--defcustom geiser-guile-extra-keywords nil
107 "Extra keywords highlighted in Guile scheme buffers."
108 :type
'(repeat string
)
109 :group
'geiser-guile
)
111 (geiser-custom--defcustom geiser-guile-case-sensitive-p t
112 "Non-nil means keyword highlighting is case-sensitive."
114 :group
'geiser-guile
)
116 (geiser-custom--defcustom geiser-guile-manual-lookup-other-window-p nil
117 "Non-nil means pop up the Info buffer in another window."
119 :group
'geiser-guile
)
121 (geiser-custom--defcustom geiser-guile-manual-lookup-nodes
122 '("Guile" "guile-2.0")
123 "List of info nodes that, when present, are used for manual lookups"
124 :type
'(repeat string
)
125 :group
'geiser-guile
)
130 (defun geiser-guile--binary ()
131 (if (listp geiser-guile-binary
)
132 (car geiser-guile-binary
)
133 geiser-guile-binary
))
135 (defun geiser-guile--parameters ()
136 "Return a list with all parameters needed to start Guile.
137 This function uses `geiser-guile-init-file' if it exists."
138 (let ((init-file (and (stringp geiser-guile-init-file
)
139 (expand-file-name geiser-guile-init-file
)))
140 (q-flags (and (not geiser-guile-load-init-file-p
) '("-q"))))
141 `(,@(and (listp geiser-guile-binary
) (cdr geiser-guile-binary
))
142 ,@q-flags
"-L" ,(expand-file-name "guile/" geiser-scheme-dir
)
143 ,@(apply 'append
(mapcar (lambda (p) (list "-L" p
))
144 geiser-guile-load-path
))
145 ,@(and init-file
(file-readable-p init-file
) (list "-l" init-file
)))))
147 ;;(defconst geiser-guile--prompt-regexp "^[^() \n]+@([^)]*?)> ")
148 (defconst geiser-guile--prompt-regexp
"[^@()]+@([^)]*?)> ")
149 (defconst geiser-guile--debugger-prompt-regexp
150 "[^@()]+@([^)]*?) \\[[0-9]+\\]> ")
153 ;;; Evaluation support:
154 (defsubst geiser-guile--linearize-args
(args)
155 (mapconcat 'identity args
" "))
157 (defun geiser-guile--geiser-procedure (proc &rest args
)
159 ((eval compile
) (format ",geiser-eval %s %s%s"
161 (geiser-guile--linearize-args (cdr args
))
162 (if (cddr args
) "" " ()")))
163 ((load-file compile-file
) (format ",geiser-load-file %s" (car args
)))
164 ((no-values) ",geiser-no-values")
165 (t (format "ge:%s (%s)" proc
(geiser-guile--linearize-args args
)))))
167 (defconst geiser-guile--module-re
168 "(define-module +\\(([^)]+)\\)")
170 (defconst geiser-guile--library-re
171 "(library +\\(([^)]+)\\)")
173 (defun geiser-guile--get-module (&optional module
)
176 (geiser-syntax--pop-to-top)
177 (if (or (re-search-backward geiser-guile--module-re nil t
)
178 (looking-at geiser-guile--library-re
)
179 (re-search-forward geiser-guile--module-re nil t
))
180 (geiser-guile--get-module (match-string-no-properties 1))
182 ((listp module
) module
)
185 (car (geiser-syntax--read-from-string module
))
189 (defun geiser-guile--module-cmd (module fmt
&optional def
)
191 (let* ((module (geiser-guile--get-module module
))
192 (module (cond ((or (null module
) (eq module
:f
)) def
)
193 (t (format "%s" module
)))))
194 (and module
(format fmt module
)))))
196 (defun geiser-guile--import-command (module)
197 (geiser-guile--module-cmd module
",use %s"))
199 (defun geiser-guile--enter-command (module)
200 (geiser-guile--module-cmd module
",m %s" "(guile-user)"))
203 (defun geiser-guile--exit-command () ",q")
205 (defun geiser-guile--symbol-begin (module)
207 (max (save-excursion (beginning-of-line) (point))
208 (save-excursion (skip-syntax-backward "^(>") (1- (point))))
209 (save-excursion (skip-syntax-backward "^'-()>") (point))))
214 (defun geiser-guile--enter-debugger ()
215 (let ((bt-cmd (format ",geiser-newline\n,error-message\n,%s\n"
216 (if geiser-guile-debug-show-bt-p
"bt" "fr"))))
217 (compilation-forget-errors)
218 (goto-char (point-max))
219 (geiser-repl--prepare-send)
220 (comint-send-string nil bt-cmd
)
221 (when geiser-guile-show-debug-help-p
222 (message "Debug REPL. Enter ,q to quit, ,h for help."))
223 (when geiser-guile-jump-on-debug-p
224 (accept-process-output (get-buffer-process (current-buffer))
226 (ignore-errors (next-error)))))
228 (defun geiser-guile--display-error (module key msg
)
230 (save-excursion (insert msg
))
231 (geiser-edit--buttonize-files))
232 (and (not key
) (not (zerop (length msg
))) msg
))
235 ;;; Trying to ascertain whether a buffer is Guile Scheme:
237 (defconst geiser-guile--guess-re
238 (format "\\(%s\\|#! *.+\\(/\\| \\)guile\\( *\\\\\\)?\\)"
239 geiser-guile--module-re
))
241 (defun geiser-guile--guess ()
243 (goto-char (point-min))
244 (re-search-forward geiser-guile--guess-re nil t
)))
247 ;;; Keywords and syntax
249 (defconst geiser-guile--builtin-keywords
250 '("call-with-input-file"
251 "call-with-input-string"
252 "call-with-output-file"
253 "call-with-output-string"
260 "define-syntax-parameter"
263 "syntax-parameterize"
267 "with-error-to-string"
271 "with-input-from-port"
272 "with-input-from-string"
273 "with-output-to-port"
274 "with-output-to-string"))
276 (defun geiser-guile--keywords ()
278 (geiser-syntax--simple-keywords geiser-guile-extra-keywords
)
279 (geiser-syntax--simple-keywords geiser-guile--builtin-keywords
)
280 `((,(rx "(" (group "define-once") eow
(* space
) (?
(group (+ word
))))
281 (1 font-lock-keyword-face
)
282 (2 font-lock-variable-name-face nil t
))
283 ("(\\(define-module\\) +(\\([^)]+\\))"
284 (1 font-lock-keyword-face
)
285 (2 font-lock-type-face nil t
)))))
287 (geiser-syntax--scheme-indent
290 (call-with-input-string 1)
291 (call-with-output-string 0)
298 (syntax-parameterize 1)
299 (with-error-to-file 1)
300 (with-error-to-port 1)
301 (with-error-to-string 0)
305 (with-input-from-string 1)
308 (with-output-to-string 0)
309 (with-throw-handler 1))
312 ;;; Compilation shell regexps
314 (defconst geiser-guile--path-rx
"^In \\([^:\n ]+\\):\n")
316 (defconst geiser-guile--rel-path-rx
"^In +\\([^/\n :]+\\):\n")
318 (defvar geiser-guile--file-cache
(make-hash-table :test
'equal
))
320 (defun geiser-guile--resolve-file (file)
321 (when (and (stringp file
)
322 (not (member file
'("socket" "stdin" "unknown file"))))
323 (if (file-name-absolute-p file
) file
324 (or (gethash file geiser-guile--file-cache
)
326 (geiser-eval--send/result
`(:eval
(:ge find-file
,file
)))
327 geiser-guile--file-cache
)))))
329 (defun geiser-guile--resolve-file-x ()
330 (let ((f (geiser-guile--resolve-file (match-string-no-properties 1))))
331 (and (stringp f
) (list f
))))
336 (defconst geiser-guile-minimum-version
"2.0")
338 (defun geiser-guile--version (binary)
339 (car (process-lines binary
"-c" "(display (version))")))
341 (defun geiser-guile-update-warning-level ()
342 "Update the warning level used by the REPL.
343 The new level is set using the value of `geiser-guile-warning-level'."
345 (let ((code `(:eval
(:ge set-warnings
',geiser-guile-warning-level
)
346 (geiser evaluation
))))
347 (geiser-eval--send/result code
)))
349 (defun connect-to-guile ()
350 "Start a Guile REPL connected to a remote process.
352 Start the external Guile process with the flag --listen to make
353 it spawn a server thread."
355 (geiser-connect 'guile
))
357 (defun geiser-guile--set-geiser-load-path ()
358 (let* ((path (expand-file-name "guile/" geiser-scheme-dir
))
359 (witness "geiser/emacs.scm")
360 (code `(begin (if (not (%search-load-path
,witness
))
361 (set! %load-path
(cons ,path %load-path
)))
363 (geiser-eval--send/wait code
)))
365 (defun geiser-guile--startup (remote)
366 (set (make-local-variable 'compilation-error-regexp-alist
)
367 `((,geiser-guile--path-rx geiser-guile--resolve-file-x
)
368 ("^ +\\([0-9]+\\):\\([0-9]+\\)" nil
1 2)))
369 (compilation-setup t
)
370 (font-lock-add-keywords nil
`((,geiser-guile--path-rx
371 1 compilation-error-face
)))
372 (let ((geiser-log-verbose-p t
))
373 (when remote
(geiser-guile--set-geiser-load-path))
374 (geiser-eval--send/wait
",use (geiser emacs)\n'done")
375 (dolist (dir geiser-guile-load-path
)
376 (let ((dir (expand-file-name dir
)))
377 (geiser-eval--send/wait
`(:eval
(:ge add-to-load-path
,dir
)))))
378 (geiser-guile-update-warning-level)))
383 (defun geiser-guile--info-spec (&optional nodes
)
384 (let* ((nrx "^[ ]+-+ [^:]+:[ ]*")
386 (res (when (Info-find-file "r5rs" t
)
387 `(("(r5rs)Index" nil
,nrx
,drx
)))))
388 (dolist (node (or nodes geiser-guile-manual-lookup-nodes
) res
)
389 (when (Info-find-file node t
)
392 (list (format "(%s)%s" node idx
) nil nrx drx
)))
393 '("Variable Index" "Procedure Index" "R5RS Index"))))))
396 (info-lookup-add-help :topic
'symbol
:mode
'geiser-guile-mode
398 :regexp
"[^()`',\" \n]+"
399 :doc-spec
(geiser-guile--info-spec))
401 (defun guile--manual-look-up (id mod
)
402 (let ((info-lookup-other-window-flag
403 geiser-guile-manual-lookup-other-window-p
))
404 (info-lookup-symbol id
'geiser-guile-mode
))
405 (when geiser-guile-manual-lookup-other-window-p
406 (switch-to-buffer-other-window "*info*"))
407 (search-forward (format "%s" id
) nil t
))
411 ;;; Implementation definition:
413 (define-geiser-implementation guile
414 (binary geiser-guile--binary
)
415 (arglist geiser-guile--parameters
)
416 (version-command geiser-guile--version
)
417 (minimum-version geiser-guile-minimum-version
)
418 (repl-startup geiser-guile--startup
)
419 (prompt-regexp geiser-guile--prompt-regexp
)
420 (debugger-prompt-regexp geiser-guile--debugger-prompt-regexp
)
421 (enter-debugger geiser-guile--enter-debugger
)
422 (marshall-procedure geiser-guile--geiser-procedure
)
423 (find-module geiser-guile--get-module
)
424 (enter-command geiser-guile--enter-command
)
425 (exit-command geiser-guile--exit-command
)
426 (import-command geiser-guile--import-command
)
427 (find-symbol-begin geiser-guile--symbol-begin
)
428 (display-error geiser-guile--display-error
)
429 (external-help guile--manual-look-up
)
430 (check-buffer geiser-guile--guess
)
431 (keywords geiser-guile--keywords
)
432 (case-sensitive geiser-guile-case-sensitive-p
))
434 (geiser-impl--add-to-alist 'regexp
"\\.scm$" 'guile t
)
437 (provide 'geiser-guile
)