1 ;;; geiser-guile.el -- guile's implementation of the geiser protocols
3 ;; Copyright (C) 2009-2018, 2020 Jose Antonio Ortega Ruiz
4 ;; Copyright (C) 2017 Jan Nieuwenhuizen <janneke@gnu.org>
6 ;; This program is free software; you can redistribute it and/or
7 ;; modify it under the terms of the Modified BSD License. You should
8 ;; have received a copy of the license along with this program. If
9 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
11 ;; Start date: Sun Mar 08, 2009 23:03
16 (require 'geiser-connection
)
17 (require 'geiser-syntax
)
18 (require 'geiser-custom
)
19 (require 'geiser-base
)
20 (require 'geiser-eval
)
21 (require 'geiser-edit
)
28 (eval-when-compile (require 'cl-lib
))
33 (defgroup geiser-guile nil
34 "Customization for Geiser's Guile flavour."
37 (geiser-custom--defcustom geiser-guile-binary
38 (cond ((eq system-type
'windows-nt
) "guile.exe")
39 ((eq system-type
'darwin
) "guile")
41 "Name to use to call the Guile executable when starting a REPL."
42 :type
'(choice string
(repeat string
))
45 (geiser-custom--defcustom geiser-guile-load-path nil
46 "A list of paths to be added to Guile's load path when it's started.
47 The paths are added to both %load-path and %load-compiled path,
48 and only if they are not already present. This variable is a
49 good candidate for an entry in your project's .dir-locals.el."
53 (geiser-custom--defcustom geiser-guile-init-file
"~/.guile-geiser"
54 "Initialization file with user code for the Guile REPL.
55 If all you want is to load ~/.guile, set
56 `geiser-guile-load-init-file-p' instead."
60 (geiser-custom--defcustom geiser-guile-load-init-file-p nil
61 "Whether to load ~/.guile when starting Guile.
62 Note that, due to peculiarities in the way Guile loads its init
63 file, using `geiser-guile-init-file' is not equivalent to setting
68 (geiser-custom--defcustom geiser-guile-debug-show-bt-p nil
69 "Whether to automatically show a full backtrace when entering the debugger.
70 If `nil', only the last frame is shown."
74 (geiser-custom--defcustom geiser-guile-jump-on-debug-p nil
75 "Whether to automatically jump to error when entering the debugger.
76 If `t', Geiser will use `next-error' to jump to the error's location."
80 (geiser-custom--defcustom geiser-guile-show-debug-help-p t
81 "Whether to show brief help in the echo area when entering the debugger."
85 (geiser-custom--defcustom geiser-guile-warning-level
'medium
86 "Verbosity of the warnings reported by Guile.
88 You can either choose one of the predefined warning sets, or
89 provide a list of symbols identifying the ones you want. Possible
90 choices are arity-mismatch, unbound-variable, unused-variable and
91 unused-toplevel. Unrecognised symbols are ignored.
93 The predefined levels are:
95 - Medium: arity-mismatch, unbound-variable, format
96 - High: arity-mismatch, unbound-variable, unused-variable, format
99 Changes to the value of this variable will automatically take
100 effect on new REPLs. For existing ones, use the command
101 \\[geiser-guile-update-warning-level]."
102 :type
'(choice (const :tag
"Medium (arity and unbound vars)" medium
)
103 (const :tag
"High (also unused vars)" high
)
104 (const :tag
"No warnings" none
)
105 (repeat :tag
"Custom" symbol
))
106 :group
'geiser-guile
)
108 (geiser-custom--defcustom geiser-guile-extra-keywords nil
109 "Extra keywords highlighted in Guile scheme buffers."
110 :type
'(repeat string
)
111 :group
'geiser-guile
)
113 (geiser-custom--defcustom geiser-guile-case-sensitive-p t
114 "Non-nil means keyword highlighting is case-sensitive."
116 :group
'geiser-guile
)
118 (geiser-custom--defcustom geiser-guile-manual-lookup-other-window-p nil
119 "Non-nil means pop up the Info buffer in another window."
121 :group
'geiser-guile
)
123 (geiser-custom--defcustom geiser-guile-manual-lookup-nodes
124 '("Guile" "guile-2.0")
125 "List of info nodes that, when present, are used for manual lookups"
126 :type
'(repeat string
)
127 :group
'geiser-guile
)
132 (defun geiser-guile--binary ()
133 (if (listp geiser-guile-binary
)
134 (car geiser-guile-binary
)
135 geiser-guile-binary
))
137 (defun geiser-guile--parameters ()
138 "Return a list with all parameters needed to start Guile.
139 This function uses `geiser-guile-init-file' if it exists."
140 (let ((init-file (and (stringp geiser-guile-init-file
)
141 (expand-file-name geiser-guile-init-file
)))
142 (q-flags (and (not geiser-guile-load-init-file-p
) '("-q"))))
143 `(,@(and (listp geiser-guile-binary
) (cdr geiser-guile-binary
))
144 ,@q-flags
"-L" ,(expand-file-name "guile/" geiser-scheme-dir
)
145 ,@(apply 'append
(mapcar (lambda (p) (list "-L" p
))
146 geiser-guile-load-path
))
147 ,@(and init-file
(file-readable-p init-file
) (list "-l" init-file
)))))
149 ;;(defconst geiser-guile--prompt-regexp "^[^() \n]+@([^)]*?)> ")
150 (defconst geiser-guile--prompt-regexp
"[^@()]+@([^)]*?)> ")
151 (defconst geiser-guile--debugger-prompt-regexp
152 "[^@()]+@([^)]*?) \\[[0-9]+\\]> ")
155 ;;; Evaluation support:
156 (defsubst geiser-guile--linearize-args
(args)
157 (mapconcat 'identity args
" "))
159 (defun geiser-guile--geiser-procedure (proc &rest args
)
161 ((eval compile
) (format ",geiser-eval %s %s%s"
163 (geiser-guile--linearize-args (cdr args
))
164 (if (cddr args
) "" " ()")))
165 ((load-file compile-file
) (format ",geiser-load-file %s" (car args
)))
166 ((no-values) ",geiser-no-values")
167 (t (format "ge:%s (%s)" proc
(geiser-guile--linearize-args args
)))))
169 (defconst geiser-guile--module-re
170 "(define-module +\\(([^)]+)\\)")
172 (defconst geiser-guile--library-re
173 "(library +\\(([^)]+)\\)")
175 (defun geiser-guile--get-module (&optional module
)
178 (geiser-syntax--pop-to-top)
179 (if (or (re-search-backward geiser-guile--module-re nil t
)
180 (re-search-backward geiser-guile--library-re nil t
)
181 (re-search-forward geiser-guile--module-re nil t
)
182 (re-search-forward geiser-guile--library-re nil t
))
183 (geiser-guile--get-module (match-string-no-properties 1))
185 ((listp module
) module
)
188 (car (geiser-syntax--read-from-string module
))
192 (defun geiser-guile--module-cmd (module fmt
&optional def
)
194 (let* ((module (geiser-guile--get-module module
))
195 (module (cond ((or (null module
) (eq module
:f
)) def
)
196 (t (format "%s" module
)))))
197 (and module
(format fmt module
)))))
199 (defun geiser-guile--import-command (module)
200 (geiser-guile--module-cmd module
",use %s"))
202 (defun geiser-guile--enter-command (module)
203 (geiser-guile--module-cmd module
",m %s" "(guile-user)"))
206 (defun geiser-guile--exit-command () ",q")
208 (defun geiser-guile--symbol-begin (module)
210 (max (save-excursion (beginning-of-line) (point))
211 (save-excursion (skip-syntax-backward "^(>") (1- (point))))
212 (save-excursion (skip-syntax-backward "^'-()>") (point))))
217 (defun geiser-guile--enter-debugger ()
218 (let ((bt-cmd (format ",geiser-newline\n,error-message\n,%s\n"
219 (if geiser-guile-debug-show-bt-p
"bt" "fr"))))
220 (compilation-forget-errors)
221 (goto-char (point-max))
222 (geiser-repl--prepare-send)
223 (comint-send-string nil bt-cmd
)
224 (when geiser-guile-show-debug-help-p
225 (message "Debug REPL. Enter ,q to quit, ,h for help."))
226 (when geiser-guile-jump-on-debug-p
227 (accept-process-output (get-buffer-process (current-buffer))
229 (ignore-errors (next-error)))))
231 (defun geiser-guile--display-error (module key msg
)
233 (save-excursion (insert msg
))
234 (geiser-edit--buttonize-files))
235 (and (not key
) (not (zerop (length msg
))) msg
))
238 ;;; Trying to ascertain whether a buffer is Guile Scheme:
240 (defconst geiser-guile--guess-re
241 (format "\\(%s\\|#! *.+\\(/\\| \\)guile\\( *\\\\\\)?\\)"
242 geiser-guile--module-re
))
244 (defun geiser-guile--guess ()
246 (goto-char (point-min))
247 (re-search-forward geiser-guile--guess-re nil t
)))
250 ;;; Keywords and syntax
252 (defconst geiser-guile--builtin-keywords
253 '("call-with-input-file"
254 "call-with-input-string"
255 "call-with-output-file"
256 "call-with-output-string"
263 "define-syntax-parameter"
266 "syntax-parameterize"
270 "with-error-to-string"
274 "with-input-from-port"
275 "with-input-from-string"
276 "with-output-to-port"
277 "with-output-to-string"))
279 (defun geiser-guile--keywords ()
281 (geiser-syntax--simple-keywords geiser-guile-extra-keywords
)
282 (geiser-syntax--simple-keywords geiser-guile--builtin-keywords
)
283 `((,(rx "(" (group "define-once") eow
(* space
) (?
(group (+ word
))))
284 (1 font-lock-keyword-face
)
285 (2 font-lock-variable-name-face nil t
))
286 ("(\\(define-module\\) +(\\([^)]+\\))"
287 (1 font-lock-keyword-face
)
288 (2 font-lock-type-face nil t
)))))
290 (geiser-syntax--scheme-indent
293 (call-with-input-string 1)
294 (call-with-output-string 0)
301 (syntax-parameterize 1)
302 (with-error-to-file 1)
303 (with-error-to-port 1)
304 (with-error-to-string 0)
308 (with-input-from-string 1)
311 (with-output-to-string 0)
312 (with-throw-handler 1))
315 ;;; Compilation shell regexps
317 (defconst geiser-guile--path-rx
"^In \\([^:\n ]+\\):\n")
319 (defconst geiser-guile--rel-path-rx
"^In +\\([^/\n :]+\\):\n")
321 (defvar geiser-guile--file-cache
(make-hash-table :test
'equal
))
323 (defun geiser-guile--resolve-file (file)
324 (when (and (stringp file
)
325 (not (member file
'("socket" "stdin" "unknown file"))))
326 (if (file-name-absolute-p file
) file
327 (or (gethash file geiser-guile--file-cache
)
329 (geiser-eval--send/result
`(:eval
(:ge find-file
,file
)))
330 geiser-guile--file-cache
)))))
332 (defun geiser-guile--resolve-file-x ()
333 (let ((f (geiser-guile--resolve-file (match-string-no-properties 1))))
334 (and (stringp f
) (list f
))))
339 (defconst geiser-guile-minimum-version
"2.2")
341 (defun geiser-guile--version (binary)
342 (car (process-lines binary
"-c" "(display (version))")))
344 (defun geiser-guile-update-warning-level ()
345 "Update the warning level used by the REPL.
346 The new level is set using the value of `geiser-guile-warning-level'."
348 (let ((code `(:eval
(:ge set-warnings
',geiser-guile-warning-level
)
349 (geiser evaluation
))))
350 (geiser-eval--send/result code
)))
352 (defun connect-to-guile ()
353 "Start a Guile REPL connected to a remote process.
355 Start the external Guile process with the flag --listen to make
356 it spawn a server thread."
358 (geiser-connect 'guile
))
360 (defun geiser-guile--set-geiser-load-path ()
361 (let* ((path (expand-file-name "guile/" geiser-scheme-dir
))
362 (witness "geiser/emacs.scm")
363 (code `(begin (if (not (%search-load-path
,witness
))
364 (set! %load-path
(cons ,path %load-path
)))
366 (geiser-eval--send/wait code
)))
368 (defvar geiser-repl--last-scm-buffer
)
370 (defun geiser-guile--startup (remote)
371 (set (make-local-variable 'compilation-error-regexp-alist
)
372 `((,geiser-guile--path-rx geiser-guile--resolve-file-x
)
373 ("^ +\\([0-9]+\\):\\([0-9]+\\)" nil
1 2)))
374 (compilation-setup t
)
375 (font-lock-add-keywords nil
`((,geiser-guile--path-rx
376 1 compilation-error-face
)))
377 (let ((geiser-log-verbose-p t
)
378 (g-load-path (buffer-local-value 'geiser-guile-load-path
379 (or geiser-repl--last-scm-buffer
381 (when remote
(geiser-guile--set-geiser-load-path))
382 (geiser-eval--send/wait
",use (geiser emacs)\n'done")
383 (dolist (dir g-load-path
)
384 (let ((dir (expand-file-name dir
)))
385 (geiser-eval--send/wait
`(:eval
(:ge add-to-load-path
,dir
)))))
386 (geiser-guile-update-warning-level)))
391 (defun geiser-guile--info-spec (&optional nodes
)
392 (let* ((nrx "^[ ]+-+ [^:]+:[ ]*")
394 (res (when (Info-find-file "r5rs" t
)
395 `(("(r5rs)Index" nil
,nrx
,drx
)))))
396 (dolist (node (or nodes geiser-guile-manual-lookup-nodes
) res
)
397 (when (Info-find-file node t
)
400 (list (format "(%s)%s" node idx
) nil nrx drx
)))
401 '("Variable Index" "Procedure Index" "R5RS Index"))))))
404 (info-lookup-add-help :topic
'symbol
:mode
'geiser-guile-mode
406 :regexp
"[^()`',\" \n]+"
407 :doc-spec
(geiser-guile--info-spec))
409 (defun guile--manual-look-up (id mod
)
410 (let ((info-lookup-other-window-flag
411 geiser-guile-manual-lookup-other-window-p
))
412 (info-lookup-symbol (symbol-name id
) 'geiser-guile-mode
))
413 (when geiser-guile-manual-lookup-other-window-p
414 (switch-to-buffer-other-window "*info*"))
415 (search-forward (format "%s" id
) nil t
))
418 ;;; Implementation definition:
420 (define-geiser-implementation guile
421 (binary geiser-guile--binary
)
422 (arglist geiser-guile--parameters
)
423 (version-command geiser-guile--version
)
424 (minimum-version geiser-guile-minimum-version
)
425 (repl-startup geiser-guile--startup
)
426 (prompt-regexp geiser-guile--prompt-regexp
)
427 (debugger-prompt-regexp geiser-guile--debugger-prompt-regexp
)
428 (enter-debugger geiser-guile--enter-debugger
)
429 (marshall-procedure geiser-guile--geiser-procedure
)
430 (find-module geiser-guile--get-module
)
431 (enter-command geiser-guile--enter-command
)
432 (exit-command geiser-guile--exit-command
)
433 (import-command geiser-guile--import-command
)
434 (find-symbol-begin geiser-guile--symbol-begin
)
435 (display-error geiser-guile--display-error
)
436 (external-help guile--manual-look-up
)
437 (check-buffer geiser-guile--guess
)
438 (keywords geiser-guile--keywords
)
439 (case-sensitive geiser-guile-case-sensitive-p
))
441 (geiser-impl--add-to-alist 'regexp
"\\.scm$" 'guile t
)
444 (provide 'geiser-guile
)