1 ;; geiser-guile.el -- guile's implementation of the geiser protocols
3 ;; Copyright (C) 2009, 2010, 2011, 2012, 2013 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
)
29 (defgroup geiser-guile nil
30 "Customization for Geiser's Guile flavour."
33 (geiser-custom--defcustom geiser-guile-binary
34 (cond ((eq system-type
'windows-nt
) "guile.exe")
35 ((eq system-type
'darwin
) "guile")
37 "Name to use to call the Guile executable when starting a REPL."
38 :type
'(choice string
(repeat string
))
41 (geiser-custom--defcustom geiser-guile-load-path nil
42 "A list of paths to be added to Guile's load path when it's
47 (geiser-custom--defcustom geiser-guile-init-file
"~/.guile-geiser"
48 "Initialization file with user code for the Guile REPL.
49 If all you want is to load ~/.guile, set
50 `geiser-guile-load-init-file-p' instead."
54 (geiser-custom--defcustom geiser-guile-load-init-file-p nil
55 "Whether to load ~/.guile when starting Guile.
56 Note that, due to peculiarities in the way Guile loads its init
57 file, using `geiser-guile-init-file' is not equivalent to setting
62 (geiser-custom--defcustom geiser-guile-debug-show-bt-p nil
63 "Whether to autmatically show a full backtrace when entering the debugger.
64 If `nil', only the last frame is shown."
68 (geiser-custom--defcustom geiser-guile-jump-on-debug-p nil
69 "Whether to autmatically jump to error when entering the debugger.
70 If `t', Geiser will use `next-error' to jump to the error's location."
74 (geiser-custom--defcustom geiser-guile-show-debug-help-p t
75 "Whether to show brief help in the echo area when entering the debugger."
79 (geiser-custom--defcustom geiser-guile-warning-level
'medium
80 "Verbosity of the warnings reported by Guile.
82 You can either choose one of the predefined warning sets, or
83 provide a list of symbols identifying the ones you want. Possible
84 choices are arity-mismatch, unbound-variable, unused-variable and
85 unused-toplevel. Unrecognised symbols are ignored.
87 The predefined levels are:
89 - Medium: arity-mismatch, unbound-variable, format
90 - High: arity-mismatch, unbound-variable, unused-variable, format
93 Changes to the value of this variable will automatically take
94 effect on new REPLs. For existing ones, use the command
95 \\[geiser-guile-update-warning-level]."
96 :type
'(choice (const :tag
"Medium (arity and unbound vars)" medium
)
97 (const :tag
"High (also unused vars)" high
)
98 (const :tag
"No warnings" none
)
99 (repeat :tag
"Custom" symbol
))
100 :group
'geiser-guile
)
102 (geiser-custom--defcustom geiser-guile-extra-keywords nil
103 "Extra keywords highlighted in Guile scheme buffers."
104 :type
'(repeat string
)
105 :group
'geiser-guile
)
107 (geiser-custom--defcustom geiser-guile-case-sensitive-p t
108 "Non-nil means keyword highlighting is case-sensitive."
110 :group
'geiser-guile
)
112 (geiser-custom--defcustom geiser-guile-manual-lookup-other-window-p nil
113 "Non-nil means pop up the Info buffer in another window."
115 :group
'geiser-guile
)
117 (geiser-custom--defcustom geiser-guile-manual-lookup-nodes
'("Guile" "guile-2.0")
118 "List of info nodes that, when present, are used for manual lookups"
119 :type
'(repeat string
)
120 :group
'geiser-guile
)
125 (defun geiser-guile--binary ()
126 (if (listp geiser-guile-binary
)
127 (car geiser-guile-binary
)
128 geiser-guile-binary
))
130 (defun geiser-guile--parameters ()
131 "Return a list with all parameters needed to start Guile.
132 This function uses `geiser-guile-init-file' if it exists."
133 (let ((init-file (and (stringp geiser-guile-init-file
)
134 (expand-file-name geiser-guile-init-file
)))
135 (q-flags (and (not geiser-guile-load-init-file-p
) '("-q"))))
136 `(,@(and (listp geiser-guile-binary
) (cdr geiser-guile-binary
))
137 ,@q-flags
"-L" ,(expand-file-name "guile/" geiser-scheme-dir
)
138 ,@(apply 'append
(mapcar (lambda (p) (list "-L" p
))
139 geiser-guile-load-path
))
140 ,@(and init-file
(file-readable-p init-file
) (list "-l" init-file
)))))
142 ;;(defconst geiser-guile--prompt-regexp "^[^() \n]+@([^)]*?)> ")
143 (defconst geiser-guile--prompt-regexp
"[^@()]+@([^)]*?)> ")
144 (defconst geiser-guile--debugger-prompt-regexp
145 "[^@()]+@([^)]*?) \\[[0-9]+\\]> ")
148 ;;; Evaluation support:
149 (defsubst geiser-guile--linearize-args
(args)
150 (mapconcat 'identity args
" "))
152 (defun geiser-guile--geiser-procedure (proc &rest args
)
154 ((eval compile
) (format ",geiser-eval %s %s%s"
156 (geiser-guile--linearize-args (cdr args
))
157 (if (cddr args
) "" " ()")))
158 ((load-file compile-file
) (format ",geiser-load-file %s" (car args
)))
159 ((no-values) ",geiser-no-values")
160 (t (format "ge:%s (%s)" proc
(geiser-guile--linearize-args args
)))))
162 (defconst geiser-guile--module-re
163 "(define-module +\\(([^)]+)\\)")
165 (defconst geiser-guile--library-re
166 "(library +\\(([^)]+)\\)")
168 (defun geiser-guile--get-module (&optional module
)
172 (while (not (zerop (geiser-syntax--nesting-level)))
174 (if (or (re-search-backward geiser-guile--module-re nil t
)
175 (looking-at geiser-guile--library-re
)
176 (re-search-forward geiser-guile--module-re nil t
))
177 (geiser-guile--get-module (match-string-no-properties 1))
179 ((listp module
) module
)
182 (car (geiser-syntax--read-from-string module
))
186 (defun geiser-guile--module-cmd (module fmt
&optional def
)
188 (let* ((module (geiser-guile--get-module module
))
189 (module (cond ((or (null module
) (eq module
:f
)) def
)
190 (t (format "%s" module
)))))
191 (and module
(format fmt module
)))))
193 (defun geiser-guile--import-command (module)
194 (geiser-guile--module-cmd module
",use %s"))
196 (defun geiser-guile--enter-command (module)
197 (geiser-guile--module-cmd module
",m %s" "(guile-user)"))
200 (defun geiser-guile--exit-command () ",q")
202 (defun geiser-guile--symbol-begin (module)
204 (max (save-excursion (beginning-of-line) (point))
205 (save-excursion (skip-syntax-backward "^(>") (1- (point))))
206 (save-excursion (skip-syntax-backward "^-()>") (point))))
211 (defun geiser-guile--enter-debugger ()
212 (let ((bt-cmd (format ",geiser-newline\n,error-message\n,%s\n"
213 (if geiser-guile-debug-show-bt-p
"bt" "fr"))))
214 (compilation-forget-errors)
215 (goto-char (point-max))
216 (geiser-repl--prepare-send)
217 (comint-send-string nil bt-cmd
)
218 (when geiser-guile-show-debug-help-p
219 (message "Debug REPL. Enter ,q to quit, ,h for help."))
220 (when geiser-guile-jump-on-debug-p
221 (accept-process-output (get-buffer-process (current-buffer))
223 (ignore-errors (next-error)))))
225 (defun geiser-guile--display-error (module key msg
)
228 (save-excursion (insert msg
))
229 (geiser-edit--buttonize-files))
230 (and (not key
) msg
(not (zerop (length msg
)))))
233 ;;; Trying to ascertain whether a buffer is Guile Scheme:
235 (defconst geiser-guile--guess-re
236 (format "\\(%s\\|#! *.+\\(/\\| \\)guile\\( *\\\\\\)?\\)"
237 geiser-guile--module-re
))
239 (defun geiser-guile--guess ()
241 (goto-char (point-min))
242 (re-search-forward geiser-guile--guess-re nil t
)))
245 ;;; Keywords and syntax
247 (defun geiser-guile--keywords ()
248 (when geiser-guile-extra-keywords
249 `((,(format "[[(]%s\\>" (regexp-opt geiser-guile-extra-keywords
1))
252 (geiser-syntax--scheme-indent
264 ;;; Compilation shell regexps
266 (defconst geiser-guile--path-rx
"^In \\([^:\n ]+\\):\n")
268 (defconst geiser-guile--rel-path-rx
"^In +\\([^/\n :]+\\):\n")
270 (defvar geiser-guile--file-cache
(make-hash-table :test
'equal
))
272 (defun geiser-guile--resolve-file (file)
273 (when (and (stringp file
)
274 (not (member file
'("socket" "stdin" "unknown file"))))
275 (if (file-name-absolute-p file
) file
276 (or (gethash file geiser-guile--file-cache
)
278 (geiser-eval--send/result
`(:eval
(:ge find-file
,file
)))
279 geiser-guile--file-cache
)))))
281 (defun geiser-guile--resolve-file-x ()
282 (let ((f (geiser-guile--resolve-file (match-string-no-properties 1))))
283 (and (stringp f
) (list f
))))
288 (defun geiser-guile-update-warning-level ()
289 "Update the warning level used by the REPL.
290 The new level is set using the value of `geiser-guile-warning-level'."
292 (let ((code `(:eval
(:ge set-warnings
',geiser-guile-warning-level
)
293 (geiser evaluation
))))
294 (geiser-eval--send/result code
)))
296 (defun connect-to-guile ()
297 "Start a Guile REPL connected to a remote process.
299 Start the external Guile process with the flag --listen to make
300 it spawn a server thread."
302 (geiser-connect 'guile
))
304 (defun geiser-guile--set-load-path ()
305 (let* ((path (expand-file-name "guile/" geiser-scheme-dir
))
306 (witness "geiser/emacs.scm")
307 (code `(begin (if (not (%search-load-path
,witness
))
308 (set! %load-path
(cons ,path %load-path
)))
310 (geiser-eval--send/wait code
)))
312 (defun geiser-guile--startup (remote)
313 (set (make-local-variable 'compilation-error-regexp-alist
)
314 `((,geiser-guile--path-rx geiser-guile--resolve-file-x
)
315 ("^ +\\([0-9]+\\):\\([0-9]+\\)" nil
1 2)))
316 (compilation-setup t
)
317 (font-lock-add-keywords nil
318 `((,geiser-guile--path-rx
1
319 compilation-error-face
)))
320 (let ((geiser-log-verbose-p t
))
321 (when remote
(geiser-guile--set-load-path))
322 (geiser-eval--send/wait
",use (geiser emacs)\n'done")
323 (geiser-guile-update-warning-level)))
328 (defun geiser-guile--info-spec (&optional nodes
)
329 (let* ((nrx "^[ ]+-+ [^:]+:[ ]*")
331 (res (when (Info-find-file "r5rs" t
)
332 `(("(r5rs)Index" nil
,nrx
,drx
)))))
333 (dolist (node (or nodes geiser-guile-manual-lookup-nodes
) res
)
334 (when (Info-find-file node t
)
337 (list (format "(%s)%s" node idx
) nil nrx drx
)))
338 '("Variable Index" "Procedure Index" "R5RS Index"))))))
341 (info-lookup-add-help :topic
'symbol
:mode
'geiser-guile-mode
343 :regexp
"[^()`',\" \n]+"
344 :doc-spec
(geiser-guile--info-spec))
346 (defun guile--manual-look-up (id mod
)
347 (let ((info-lookup-other-window-flag
348 geiser-guile-manual-lookup-other-window-p
))
349 (info-lookup-symbol id
'geiser-guile-mode
))
350 (when geiser-guile-manual-lookup-other-window-p
351 (switch-to-buffer-other-window "*info*"))
352 (search-forward (format "%s" id
) nil t
))
356 ;;; Implementation definition:
358 (define-geiser-implementation guile
359 (binary geiser-guile--binary
)
360 (arglist geiser-guile--parameters
)
361 (repl-startup geiser-guile--startup
)
362 (prompt-regexp geiser-guile--prompt-regexp
)
363 (debugger-prompt-regexp geiser-guile--debugger-prompt-regexp
)
364 (enter-debugger geiser-guile--enter-debugger
)
365 (marshall-procedure geiser-guile--geiser-procedure
)
366 (find-module geiser-guile--get-module
)
367 (enter-command geiser-guile--enter-command
)
368 (exit-command geiser-guile--exit-command
)
369 (import-command geiser-guile--import-command
)
370 (find-symbol-begin geiser-guile--symbol-begin
)
371 (display-error geiser-guile--display-error
)
372 (external-help guile--manual-look-up
)
373 (check-buffer geiser-guile--guess
)
374 (keywords geiser-guile--keywords
)
375 (case-sensitive geiser-guile-case-sensitive-p
))
377 (geiser-impl--add-to-alist 'regexp
"\\.scm$" 'guile t
)
380 (provide 'geiser-guile
)