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
)
27 (defgroup geiser-guile nil
28 "Customization for Geiser's Guile flavour."
31 (geiser-custom--defcustom geiser-guile-binary
32 (cond ((eq system-type
'windows-nt
) "guile.exe")
33 ((eq system-type
'darwin
) "guile")
35 "Name to use to call the Guile executable when starting a REPL."
36 :type
'(choice string
(repeat string
))
39 (geiser-custom--defcustom geiser-guile-load-path nil
40 "A list of paths to be added to Guile's load path when it's
45 (geiser-custom--defcustom geiser-guile-init-file
"~/.guile-geiser"
46 "Initialization file with user code for the Guile REPL."
50 (geiser-custom--defcustom geiser-guile-debug-show-bt-p nil
51 "Whether to autmatically show a full backtrace when entering the debugger.
52 If `nil', only the last frame is shown."
56 (geiser-custom--defcustom geiser-guile-jump-on-debug-p nil
57 "Whether to autmatically jump to error when entering the debugger.
58 If `t', Geiser will use `next-error' to jump to the error's location."
62 (geiser-custom--defcustom geiser-guile-show-debug-help-p t
63 "Whether to show brief help in the echo area when entering the debugger."
67 (geiser-custom--defcustom geiser-guile-warning-level
'medium
68 "Verbosity of the warnings reported by Guile.
70 You can choose either one of the predefined warning sets, or
71 provide a list of symbols identifying the ones you want. Possible
72 choices are arity-mismatch, unbound-variable, unused-variable and
73 unused-toplevel. Unrecognised symbols are ignored.
75 The predefined levels are:
77 - Medium: arity-mismatch, unbound-variable
78 - High: arity-mismatch, unbound-variable, unused-variable
81 Changes to the value of this variable will automatically take
82 effect on new REPLs. For existing ones, use the command
83 \\[geiser-guile-update-warning-level]."
84 :type
'(choice (const :tag
"Medium (arity and unbound vars)" medium
)
85 (const :tag
"High (also unused vars)" high
)
86 (const :tag
"No warnings" none
)
87 (repeat :tag
"Custom" symbol
))
93 (defun geiser-guile--binary ()
94 (if (listp geiser-guile-binary
)
95 (car geiser-guile-binary
)
98 (defun geiser-guile--parameters ()
99 "Return a list with all parameters needed to start Guile.
100 This function uses `geiser-guile-init-file' if it exists."
101 (let ((init-file (and (stringp geiser-guile-init-file
)
102 (expand-file-name geiser-guile-init-file
))))
103 `(,@(and (listp geiser-guile-binary
) (cdr geiser-guile-binary
))
105 ,@(apply 'append
(mapcar (lambda (p) (list "-L" p
)) geiser-guile-load-path
))
106 ,@(and init-file
(file-readable-p init-file
) (list "-l" init-file
)))))
108 (defconst geiser-guile--prompt-regexp
"^[^() \n]+@([^)]*?)> ")
109 (defconst geiser-guile--debugger-prompt-regexp
110 "^[^() \n]+@([^)]*?) \\[[0-9]+\\]> ")
111 (defconst geiser-guile--debugger-preamble-regexp
112 "^Entering a new prompt\\. ")
115 ;;; Evaluation support:
117 (defun geiser-guile--geiser-procedure (proc &rest args
)
119 ((eval compile
) (format "((@ (geiser emacs) ge:compile) '%s '%s)"
120 (mapconcat 'identity
(cdr args
) " ")
121 (or (car args
) "#f")))
122 ((load-file compile-file
)
123 (format "((@ (geiser emacs) ge:%s) %s)" proc
(car args
)))
124 ((no-values) "((@ (guile) values))")
125 (t (format "(apply (@ (geiser emacs) ge:%s) (list %s))"
126 proc
(mapconcat 'identity args
"")))))
128 (defconst geiser-guile--module-re
129 "(define-module +\\(([^)]+)\\)")
131 (defun geiser-guile--get-module (&optional module
)
135 (while (not (zerop (geiser-syntax--nesting-level)))
137 (if (re-search-backward geiser-guile--module-re nil t
)
138 (geiser-guile--get-module (match-string-no-properties 1))
140 ((listp module
) module
)
143 (car (geiser-syntax--read-from-string module
))
147 (defun geiser-guile--module-cmd (module fmt
&optional def
)
149 (let* ((module (geiser-guile--get-module module
))
150 (module (cond ((or (null module
) (eq module
:f
)) def
)
151 (t (format "%s" module
)))))
152 (and module
(format fmt module
)))))
154 (defun geiser-guile--import-command (module)
155 (geiser-guile--module-cmd module
",use %s"))
157 (defun geiser-guile--enter-command (module)
158 (geiser-guile--module-cmd module
",m %s" "(guile-user)"))
161 (defun geiser-guile--exit-command () ",q")
163 (defun geiser-guile--symbol-begin (module)
165 (max (save-excursion (beginning-of-line) (point))
166 (save-excursion (skip-syntax-backward "^(>") (1- (point))))
167 (save-excursion (skip-syntax-backward "^-()>") (point))))
172 (defun geiser-guile--enter-debugger ()
173 (let ((bt-cmd (format ",%s\n"
174 (if geiser-guile-debug-show-bt-p
"bt" "fr"))))
175 (compilation-forget-errors)
176 (goto-char (point-max))
177 (comint-send-string nil
"((@ (geiser emacs) ge:newline))\n")
178 (comint-send-string nil
",error-message\n")
179 (comint-send-string nil bt-cmd
)
180 (when geiser-guile-show-debug-help-p
181 (message "Debug REPL. Enter ,q to quit, ,h for help."))
182 (when geiser-guile-jump-on-debug-p
183 (accept-process-output (get-buffer-process (current-buffer))
185 (ignore-errors (next-error)))))
187 (defun geiser-guile--display-error (module key msg
)
190 (save-excursion (insert msg
))
191 (geiser-edit--buttonize-files))
192 (and (not key
) msg
(not (zerop (length msg
)))))
195 ;;; Trying to ascertain whether a buffer is Guile Scheme:
197 (defconst geiser-guile--guess-re
198 (format "\\(%s\\|#! *.+\\(/\\| \\)guile\\( *\\\\\\)?\\)"
199 geiser-guile--module-re
))
201 (defun geiser-guile--guess ()
203 (goto-char (point-min))
204 (re-search-forward geiser-guile--guess-re nil t
)))
207 ;;; Compilation shell regexps
209 (defconst geiser-guile--path-rx
"^In \\([^:\n ]+\\):\n")
211 (defconst geiser-guile--rel-path-rx
"^In +\\([^/\n :]+\\):\n")
213 (defvar geiser-guile--file-cache
(make-hash-table :test
'equal
))
215 (defun geiser-guile--resolve-file (file)
216 (when (and (stringp file
) (not (string-equal file
"unknown file")))
217 (if (file-name-absolute-p file
) file
218 (or (gethash file geiser-guile--file-cache
)
220 (geiser-eval--send/result
`(:eval
(:ge find-file
,file
)))
221 geiser-guile--file-cache
)))))
223 (defun geiser-guile--resolve-file-x ()
224 (let ((f (geiser-guile--resolve-file (match-string-no-properties 1))))
230 (defun geiser-guile-update-warning-level ()
231 "Update the warning level used by the REPL.
232 The new level is set using the value of `geiser-guile-warning-level'."
234 (let ((code `(:eval
(ge:set-warnings
',geiser-guile-warning-level
)
235 (geiser evaluation
))))
236 (geiser-eval--send/result code
)))
238 (defun connect-to-guile ()
239 "Start a Guile REPL connected to a remote process.
241 Start the external Guile process with the flag --listen to make
242 it spawn a server thread."
244 (geiser-connect 'guile
))
246 (defun geiser-guile--startup ()
247 (set (make-local-variable 'compilation-error-regexp-alist
)
248 `((,geiser-guile--path-rx geiser-guile--resolve-file-x
)
249 ("^ +\\([0-9]+\\):\\([0-9]+\\)" nil
1 2)))
250 (setq geiser-con--debugging-inhibits-eval nil
)
251 (compilation-setup t
)
252 (font-lock-add-keywords nil
253 `((,geiser-guile--path-rx
1
254 compilation-error-face
)))
255 (geiser-eval--send/wait
256 `(:scm
,(format "(set! %%load-path (cons %S %%load-path))"
257 (expand-file-name "guile/" geiser-scheme-dir
))))
258 (geiser-guile-update-warning-level))
261 ;;; Implementation definition:
263 (define-geiser-implementation guile
264 (binary geiser-guile--binary
)
265 (arglist geiser-guile--parameters
)
266 (startup geiser-guile--startup
)
267 (prompt-regexp geiser-guile--prompt-regexp
)
268 (enter-debugger geiser-guile--enter-debugger
)
269 (debugger-prompt-regexp geiser-guile--debugger-prompt-regexp
)
270 (debugger-preamble-regexp geiser-guile--debugger-preamble-regexp
)
271 (marshall-procedure geiser-guile--geiser-procedure
)
272 (find-module geiser-guile--get-module
)
273 (enter-command geiser-guile--enter-command
)
274 (exit-command geiser-guile--exit-command
)
275 (import-command geiser-guile--import-command
)
276 (find-symbol-begin geiser-guile--symbol-begin
)
277 (display-error geiser-guile--display-error
)
279 (check-buffer geiser-guile--guess
))
281 (geiser-impl--add-to-alist 'regexp
"\\.scm$" 'guile nil
)
284 (provide 'geiser-guile
)
285 ;;; geiser-guile.el ends here