1 ;; geiser-guile.el -- guile's implementation of the geiser protocols
3 ;; Copyright (C) 2009, 2010, 2011, 2012 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-manual-lookup-other-window-p nil
108 "Non-nil means pop up the Info buffer in another window."
110 :group
'geiser-guile
)
112 (geiser-custom--defcustom geiser-guile-manual-lookup-nodes
'("Guile" "guile-2.0")
113 "List of info nodes that, when present, are used for manual lookups"
114 :type
'(repeat string
)
115 :group
'geiser-guile
)
120 (defun geiser-guile--binary ()
121 (if (listp geiser-guile-binary
)
122 (car geiser-guile-binary
)
123 geiser-guile-binary
))
125 (defun geiser-guile--parameters ()
126 "Return a list with all parameters needed to start Guile.
127 This function uses `geiser-guile-init-file' if it exists."
128 (let ((init-file (and (stringp geiser-guile-init-file
)
129 (expand-file-name geiser-guile-init-file
)))
130 (q-flags (and (not geiser-guile-load-init-file-p
) '("-q"))))
131 `(,@(and (listp geiser-guile-binary
) (cdr geiser-guile-binary
))
132 ,@q-flags
"-L" ,(expand-file-name "guile/" geiser-scheme-dir
)
133 ,@(apply 'append
(mapcar (lambda (p) (list "-L" p
))
134 geiser-guile-load-path
))
135 ,@(and init-file
(file-readable-p init-file
) (list "-l" init-file
)))))
137 ;;(defconst geiser-guile--prompt-regexp "^[^() \n]+@([^)]*?)> ")
138 (defconst geiser-guile--prompt-regexp
"[^@()]+@([^)]*?)> ")
139 (defconst geiser-guile--debugger-prompt-regexp
140 "[^@()]+@([^)]*?) \\[[0-9]+\\]> ")
143 ;;; Evaluation support:
144 (defsubst geiser-guile--linearize-args
(args)
145 (mapconcat 'identity args
" "))
147 (defun geiser-guile--geiser-procedure (proc &rest args
)
149 ((eval compile
) (format ",geiser-eval %s %s%s"
151 (geiser-guile--linearize-args (cdr args
))
152 (if (cddr args
) "" " ()")))
153 ((load-file compile-file
) (format ",geiser-load-file %s" (car args
)))
154 ((no-values) ",geiser-no-values")
155 (t (format "ge:%s (%s)" proc
(geiser-guile--linearize-args args
)))))
157 (defconst geiser-guile--module-re
158 "(define-module +\\(([^)]+)\\)")
160 (defconst geiser-guile--library-re
161 "(library +\\(([^)]+)\\)")
163 (defun geiser-guile--get-module (&optional module
)
167 (while (not (zerop (geiser-syntax--nesting-level)))
169 (if (or (re-search-backward geiser-guile--module-re nil t
)
170 (looking-at geiser-guile--library-re
)
171 (re-search-forward geiser-guile--module-re nil t
))
172 (geiser-guile--get-module (match-string-no-properties 1))
174 ((listp module
) module
)
177 (car (geiser-syntax--read-from-string module
))
181 (defun geiser-guile--module-cmd (module fmt
&optional def
)
183 (let* ((module (geiser-guile--get-module module
))
184 (module (cond ((or (null module
) (eq module
:f
)) def
)
185 (t (format "%s" module
)))))
186 (and module
(format fmt module
)))))
188 (defun geiser-guile--import-command (module)
189 (geiser-guile--module-cmd module
",use %s"))
191 (defun geiser-guile--enter-command (module)
192 (geiser-guile--module-cmd module
",m %s" "(guile-user)"))
195 (defun geiser-guile--exit-command () ",q")
197 (defun geiser-guile--symbol-begin (module)
199 (max (save-excursion (beginning-of-line) (point))
200 (save-excursion (skip-syntax-backward "^(>") (1- (point))))
201 (save-excursion (skip-syntax-backward "^-()>") (point))))
206 (defun geiser-guile--enter-debugger ()
207 (let ((bt-cmd (format ",geiser-newline\n,error-message\n,%s\n"
208 (if geiser-guile-debug-show-bt-p
"bt" "fr"))))
209 (compilation-forget-errors)
210 (goto-char (point-max))
211 (geiser-repl--prepare-send)
212 (comint-send-string nil bt-cmd
)
213 (when geiser-guile-show-debug-help-p
214 (message "Debug REPL. Enter ,q to quit, ,h for help."))
215 (when geiser-guile-jump-on-debug-p
216 (accept-process-output (get-buffer-process (current-buffer))
218 (ignore-errors (next-error)))))
220 (defun geiser-guile--display-error (module key msg
)
223 (save-excursion (insert msg
))
224 (geiser-edit--buttonize-files))
225 (and (not key
) msg
(not (zerop (length msg
)))))
228 ;;; Trying to ascertain whether a buffer is Guile Scheme:
230 (defconst geiser-guile--guess-re
231 (format "\\(%s\\|#! *.+\\(/\\| \\)guile\\( *\\\\\\)?\\)"
232 geiser-guile--module-re
))
234 (defun geiser-guile--guess ()
236 (goto-char (point-min))
237 (re-search-forward geiser-guile--guess-re nil t
)))
240 ;;; Keywords and syntax
242 (defun geiser-guile--keywords ()
243 (when geiser-guile-extra-keywords
244 `((,(format "[[(]%s\\>" (regexp-opt geiser-guile-extra-keywords
1))
247 (geiser-syntax--scheme-indent
259 ;;; Compilation shell regexps
261 (defconst geiser-guile--path-rx
"^In \\([^:\n ]+\\):\n")
263 (defconst geiser-guile--rel-path-rx
"^In +\\([^/\n :]+\\):\n")
265 (defvar geiser-guile--file-cache
(make-hash-table :test
'equal
))
267 (defun geiser-guile--resolve-file (file)
268 (when (and (stringp file
)
269 (not (member file
'("socket" "stdin" "unknown file"))))
270 (if (file-name-absolute-p file
) file
271 (or (gethash file geiser-guile--file-cache
)
273 (geiser-eval--send/result
`(:eval
(:ge find-file
,file
)))
274 geiser-guile--file-cache
)))))
276 (defun geiser-guile--resolve-file-x ()
277 (let ((f (geiser-guile--resolve-file (match-string-no-properties 1))))
278 (and (stringp f
) (list f
))))
283 (defun geiser-guile-update-warning-level ()
284 "Update the warning level used by the REPL.
285 The new level is set using the value of `geiser-guile-warning-level'."
287 (let ((code `(:eval
(:ge set-warnings
',geiser-guile-warning-level
)
288 (geiser evaluation
))))
289 (geiser-eval--send/result code
)))
291 (defun connect-to-guile ()
292 "Start a Guile REPL connected to a remote process.
294 Start the external Guile process with the flag --listen to make
295 it spawn a server thread."
297 (geiser-connect 'guile
))
299 (defun geiser-guile--set-load-path ()
300 (let* ((path (expand-file-name "guile/" geiser-scheme-dir
))
301 (witness "geiser/emacs.scm")
302 (code `(begin (if (not (%search-load-path
,witness
))
303 (set! %load-path
(cons ,path %load-path
)))
305 (geiser-eval--send/wait code
)))
307 (defun geiser-guile--startup (remote)
308 (set (make-local-variable 'compilation-error-regexp-alist
)
309 `((,geiser-guile--path-rx geiser-guile--resolve-file-x
)
310 ("^ +\\([0-9]+\\):\\([0-9]+\\)" nil
1 2)))
311 (compilation-setup t
)
312 (font-lock-add-keywords nil
313 `((,geiser-guile--path-rx
1
314 compilation-error-face
)))
315 (let ((geiser-log-verbose-p t
))
316 (when remote
(geiser-guile--set-load-path))
317 (geiser-eval--send/wait
",use (geiser emacs)\n'done")
318 (geiser-guile-update-warning-level)))
323 (defun geiser-guile--info-spec (&optional nodes
)
324 (let* ((nrx "^[ ]+-+ [^:]+:[ ]*")
326 (res (when (Info-find-file "r5rs" t
) `(("(r5rs)Index" nil
,nrx
,drx
)))))
327 (dolist (node (or nodes geiser-guile-manual-lookup-nodes
) res
)
328 (when (Info-find-file node t
)
330 (add-to-list 'res
(list (format "(%s)%s" node idx
) nil nrx drx
)))
331 '("Variable Index" "Procedure Index" "R5RS Index"))))))
334 (info-lookup-add-help :topic
'symbol
:mode
'geiser-guile-mode
336 :regexp
"[^()`',\" \n]+"
337 :doc-spec
(geiser-guile--info-spec))
339 (defun guile--manual-look-up (id mod
)
340 (let ((info-lookup-other-window-flag
341 geiser-guile-manual-lookup-other-window-p
))
342 (info-lookup-symbol id
'geiser-guile-mode
))
343 (when geiser-guile-manual-lookup-other-window-p
344 (switch-to-buffer-other-window "*info*"))
345 (search-forward (format "%s" id
) nil t
))
349 ;;; Implementation definition:
351 (define-geiser-implementation guile
352 (binary geiser-guile--binary
)
353 (arglist geiser-guile--parameters
)
354 (repl-startup geiser-guile--startup
)
355 (prompt-regexp geiser-guile--prompt-regexp
)
356 (debugger-prompt-regexp geiser-guile--debugger-prompt-regexp
)
357 (enter-debugger geiser-guile--enter-debugger
)
358 (marshall-procedure geiser-guile--geiser-procedure
)
359 (find-module geiser-guile--get-module
)
360 (enter-command geiser-guile--enter-command
)
361 (exit-command geiser-guile--exit-command
)
362 (import-command geiser-guile--import-command
)
363 (find-symbol-begin geiser-guile--symbol-begin
)
364 (display-error geiser-guile--display-error
)
365 (external-help guile--manual-look-up
)
366 (check-buffer geiser-guile--guess
)
367 (keywords geiser-guile--keywords
))
369 (geiser-impl--add-to-alist 'regexp
"\\.scm$" 'guile t
)
372 (provide 'geiser-guile
)