1 ;; geiser-guile.el -- guile's implementation of the geiser protocols
3 ;; Copyright (C) 2009, 2010 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
)
28 (defgroup geiser-guile nil
29 "Customization for Geiser's Guile flavour."
32 (geiser-custom--defcustom geiser-guile-binary
33 (cond ((eq system-type
'windows-nt
) "guile.exe")
34 ((eq system-type
'darwin
) "guile")
36 "Name to use to call the Guile executable when starting a REPL."
37 :type
'(choice string
(repeat string
))
40 (geiser-custom--defcustom geiser-guile-load-path nil
41 "A list of paths to be added to Guile's load path when it's
46 (geiser-custom--defcustom geiser-guile-init-file
"~/.guile-geiser"
47 "Initialization file with user code for the Guile REPL."
51 (geiser-custom--defcustom geiser-guile-debug-show-bt-p nil
52 "Whether to autmatically show a full backtrace when entering the debugger.
53 If `nil', only the last frame is shown."
57 (geiser-custom--defcustom geiser-guile-jump-on-debug-p nil
58 "Whether to autmatically jump to error when entering the debugger.
59 If `t', Geiser will use `next-error' to jump to the error's location."
63 (geiser-custom--defcustom geiser-guile-show-debug-help-p t
64 "Whether to show brief help in the echo area when entering the debugger."
68 (geiser-custom--defcustom geiser-guile-warning-level
'medium
69 "Verbosity of the warnings reported by Guile.
71 You can either choose one of the predefined warning sets, or
72 provide a list of symbols identifying the ones you want. Possible
73 choices are arity-mismatch, unbound-variable, unused-variable and
74 unused-toplevel. Unrecognised symbols are ignored.
76 The predefined levels are:
78 - Medium: arity-mismatch, unbound-variable
79 - High: arity-mismatch, unbound-variable, unused-variable
82 Changes to the value of this variable will automatically take
83 effect on new REPLs. For existing ones, use the command
84 \\[geiser-guile-update-warning-level]."
85 :type
'(choice (const :tag
"Medium (arity and unbound vars)" medium
)
86 (const :tag
"High (also unused vars)" high
)
87 (const :tag
"No warnings" none
)
88 (repeat :tag
"Custom" symbol
))
91 (geiser-custom--defcustom geiser-guile-extra-keywords nil
92 "Extra keywords highlighted in Guile scheme buffers."
93 :type
'(repeat string
)
96 (geiser-custom--defcustom geiser-guile-manual-lookup-other-window-p nil
97 "Non-nil means pop up the Info buffer in another window."
104 (defun geiser-guile--binary ()
105 (if (listp geiser-guile-binary
)
106 (car geiser-guile-binary
)
107 geiser-guile-binary
))
109 (defun geiser-guile--parameters ()
110 "Return a list with all parameters needed to start Guile.
111 This function uses `geiser-guile-init-file' if it exists."
112 (let ((init-file (and (stringp geiser-guile-init-file
)
113 (expand-file-name geiser-guile-init-file
))))
114 `(,@(and (listp geiser-guile-binary
) (cdr geiser-guile-binary
))
115 "-q" "-L" ,(expand-file-name "guile/" geiser-scheme-dir
)
116 ,@(apply 'append
(mapcar (lambda (p) (list "-L" p
)) geiser-guile-load-path
))
117 ,@(and init-file
(file-readable-p init-file
) (list "-l" init-file
)))))
119 ;;(defconst geiser-guile--prompt-regexp "^[^() \n]+@([^)]*?)> ")
120 (defconst geiser-guile--prompt-regexp
"[^@()]+@([^)]*?)> ")
121 (defconst geiser-guile--debugger-prompt-regexp
122 "[^@()]+@([^)]*?) \\[[0-9]+\\]> ")
125 ;;; Evaluation support:
126 (defsubst geiser-guile--linearize-args
(args)
127 (mapconcat 'identity args
" "))
129 (defun geiser-guile--geiser-procedure (proc &rest args
)
131 ((eval compile
) (format ",geiser-eval %s %s%s"
133 (geiser-guile--linearize-args (cdr args
))
134 (if (cddr args
) "" " ()")))
135 ((load-file compile-file
) (format ",geiser-load-file %s" (car args
)))
136 ((no-values) ",geiser-no-values")
137 (t (format "ge:%s (%s)" proc
(geiser-guile--linearize-args args
)))))
139 (defconst geiser-guile--module-re
140 "(define-module +\\(([^)]+)\\)")
142 (defconst geiser-guile--library-re
143 "(library +\\(([^)]+)\\)")
145 (defun geiser-guile--get-module (&optional module
)
149 (while (not (zerop (geiser-syntax--nesting-level)))
151 (if (or (re-search-backward geiser-guile--module-re nil t
)
152 (looking-at geiser-guile--library-re
))
153 (geiser-guile--get-module (match-string-no-properties 1))
155 ((listp module
) module
)
158 (car (geiser-syntax--read-from-string module
))
162 (defun geiser-guile--module-cmd (module fmt
&optional def
)
164 (let* ((module (geiser-guile--get-module module
))
165 (module (cond ((or (null module
) (eq module
:f
)) def
)
166 (t (format "%s" module
)))))
167 (and module
(format fmt module
)))))
169 (defun geiser-guile--import-command (module)
170 (geiser-guile--module-cmd module
",use %s"))
172 (defun geiser-guile--enter-command (module)
173 (geiser-guile--module-cmd module
",m %s" "(guile-user)"))
176 (defun geiser-guile--exit-command () ",q")
178 (defun geiser-guile--symbol-begin (module)
180 (max (save-excursion (beginning-of-line) (point))
181 (save-excursion (skip-syntax-backward "^(>") (1- (point))))
182 (save-excursion (skip-syntax-backward "^-()>") (point))))
187 (defun geiser-guile--enter-debugger ()
188 (let ((bt-cmd (format ",geiser-newline\n,error-message\n,%s\n"
189 (if geiser-guile-debug-show-bt-p
"bt" "fr"))))
190 (compilation-forget-errors)
191 (goto-char (point-max))
192 (geiser-repl--prepare-send)
193 (comint-send-string nil bt-cmd
)
194 (when geiser-guile-show-debug-help-p
195 (message "Debug REPL. Enter ,q to quit, ,h for help."))
196 (when geiser-guile-jump-on-debug-p
197 (accept-process-output (get-buffer-process (current-buffer))
199 (ignore-errors (next-error)))))
201 (defun geiser-guile--display-error (module key msg
)
204 (save-excursion (insert msg
))
205 (geiser-edit--buttonize-files))
206 (and (not key
) msg
(not (zerop (length msg
)))))
209 ;;; Trying to ascertain whether a buffer is Guile Scheme:
211 (defconst geiser-guile--guess-re
212 (format "\\(%s\\|#! *.+\\(/\\| \\)guile\\( *\\\\\\)?\\)"
213 geiser-guile--module-re
))
215 (defun geiser-guile--guess ()
217 (goto-char (point-min))
218 (re-search-forward geiser-guile--guess-re nil t
)))
222 (defun geiser-guile--keywords ()
223 (when geiser-guile-extra-keywords
224 `((,(format "[[(]%s\\>" (regexp-opt geiser-guile-extra-keywords
1))
228 ;;; Compilation shell regexps
230 (defconst geiser-guile--path-rx
"^In \\([^:\n ]+\\):\n")
232 (defconst geiser-guile--rel-path-rx
"^In +\\([^/\n :]+\\):\n")
234 (defvar geiser-guile--file-cache
(make-hash-table :test
'equal
))
236 (defun geiser-guile--resolve-file (file)
237 (when (and (stringp file
) (not (string-equal file
"unknown file")))
238 (if (file-name-absolute-p file
) file
239 (or (gethash file geiser-guile--file-cache
)
241 (geiser-eval--send/result
`(:eval
(:ge find-file
,file
)))
242 geiser-guile--file-cache
)))))
244 (defun geiser-guile--resolve-file-x ()
245 (let ((f (geiser-guile--resolve-file (match-string-no-properties 1))))
246 (and (stringp f
) (list f
))))
251 (defun geiser-guile-update-warning-level ()
252 "Update the warning level used by the REPL.
253 The new level is set using the value of `geiser-guile-warning-level'."
255 (let ((code `(:eval
(:ge set-warnings
',geiser-guile-warning-level
)
256 (geiser evaluation
))))
257 (geiser-eval--send/result code
)))
259 (defun connect-to-guile ()
260 "Start a Guile REPL connected to a remote process.
262 Start the external Guile process with the flag --listen to make
263 it spawn a server thread."
265 (geiser-connect 'guile
))
267 (defun geiser-guile--load-path-string ()
268 (let* ((path (expand-file-name "guile/" geiser-scheme-dir
))
269 (witness "geiser/emacs.scm")
270 (code `(if (not (%search-load-path
,witness
))
271 (set! %load-path
(cons ,path %load-path
)))))
272 (geiser-eval--scheme-str code
)))
274 (defun geiser-guile--startup (remote)
275 (set (make-local-variable 'compilation-error-regexp-alist
)
276 `((,geiser-guile--path-rx geiser-guile--resolve-file-x
)
277 ("^ +\\([0-9]+\\):\\([0-9]+\\)" nil
1 2)))
278 (compilation-setup t
)
279 (font-lock-add-keywords nil
280 `((,geiser-guile--path-rx
1
281 compilation-error-face
)))
283 (geiser-repl--send-silent (geiser-guile--load-path-string)))
284 (geiser-repl--send-silent ",use (geiser emacs)")
285 (geiser-guile-update-warning-level))
289 (info-lookup-add-help :topic
'symbol
:mode
'geiser-guile-mode
291 :regexp
"[^()`',\" \n]+"
293 '(("(r5rs)Index" nil
"^[ ]+-+ [^:]+:[ ]*" "\\b")
294 ("(Guile)R5RS Index" nil
"^ - [^:]+: " "\\b")
295 ("(Guile)Procedure Index" nil
"^ - [^:]+: " "\\b")
296 ("(Guile)Variable Index" nil
"^ - [^:]+: " "\\b")))
298 (defun guile--manual-look-up (id mod
)
299 (let ((info-lookup-other-window-flag
300 geiser-guile-manual-lookup-other-window-p
))
301 (info-lookup-symbol id
'geiser-guile-mode
))
302 (when geiser-guile-manual-lookup-other-window-p
303 (switch-to-buffer-other-window "*info*"))
304 (search-forward (format "%s" id
) nil t
))
308 ;;; Implementation definition:
310 (define-geiser-implementation guile
311 (binary geiser-guile--binary
)
312 (arglist geiser-guile--parameters
)
313 (repl-startup geiser-guile--startup
)
314 (prompt-regexp geiser-guile--prompt-regexp
)
315 (debugger-prompt-regexp geiser-guile--debugger-prompt-regexp
)
316 (enter-debugger geiser-guile--enter-debugger
)
317 (marshall-procedure geiser-guile--geiser-procedure
)
318 (find-module geiser-guile--get-module
)
319 (enter-command geiser-guile--enter-command
)
320 (exit-command geiser-guile--exit-command
)
321 (import-command geiser-guile--import-command
)
322 (find-symbol-begin geiser-guile--symbol-begin
)
323 (display-error geiser-guile--display-error
)
324 (external-help guile--manual-look-up
)
325 (check-buffer geiser-guile--guess
)
326 (keywords geiser-guile--keywords
))
328 (geiser-impl--add-to-alist 'regexp
"\\.scm$" 'guile nil
)
331 (provide 'geiser-guile
)
332 ;;; geiser-guile.el ends here