1 ;; geiser-impl.el -- generic support for scheme implementations
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: Sat Mar 07, 2009 23:32
14 (require 'geiser-custom
)
15 (require 'geiser-base
)
22 (defgroup geiser-implementation nil
23 "Generic support for multiple Scheme implementations."
26 (geiser-custom--defcustom geiser-default-implementation nil
27 "Symbol naming the default Scheme implementation."
29 :group
'geiser-implementation
)
31 (geiser-custom--defcustom geiser-active-implementations
'(guile racket
)
32 "List of active installed Scheme implementations."
33 :type
'(repeat symbol
)
34 :group
'geiser-implementation
)
36 (geiser-custom--defcustom geiser-implementations-alist nil
37 "A map from regular expressions or directories to implementations.
38 When opening a new file, its full path will be matched against
39 each one of the regular expressions or directories in this map in order to
40 determine its scheme flavour."
41 :type
'(repeat (list (choice (group :tag
"Regular expression"
42 (const regexp
) regexp
)
43 (group :tag
"Directory"
44 (const dir
) directory
))
46 :group
'geiser-implementation
)
49 ;;; Implementation registry:
51 (defvar geiser-impl--registry nil
)
52 (defvar geiser-impl--load-files nil
)
53 (defvar geiser-impl--method-docs nil
)
54 (defvar geiser-impl--local-methods nil
)
55 (defvar geiser-impl--local-variables nil
)
57 (geiser-custom--memoize 'geiser-impl--load-files
)
59 (make-variable-buffer-local
60 (defvar geiser-impl--implementation nil
))
62 (defsubst geiser-impl--impl-str
(&optional impl
)
63 (let ((impl (or impl geiser-impl--implementation
)))
64 (and impl
(capitalize (format "%s" impl
)))))
66 (defsubst geiser-impl--feature
(impl)
67 (intern (format "geiser-%s" impl
)))
69 (defsubst geiser-impl--load-impl
(impl)
70 (require (geiser-impl--feature impl
)
71 (cdr (assq impl geiser-impl--load-files
))
74 (defsubst geiser-impl--methods
(impl)
75 (cdr (assq impl geiser-impl--registry
)))
77 (defun geiser-impl--method (method &optional impl
)
79 geiser-impl--implementation
80 geiser-default-implementation
)))
81 (cadr (assq method
(geiser-impl--methods impl
)))))
83 (defun geiser-impl--call-method (method impl
&rest args
)
84 (let ((fun (geiser-impl--method method impl
)))
85 (when (functionp fun
) (apply fun args
))))
87 (defun geiser-impl--method-doc (method doc user
)
88 (let* ((user (if user
(format " Used via `%s'." user
) ""))
89 (extra-doc (format "%s%s" doc user
)))
90 (add-to-list 'geiser-impl--method-docs
(cons method extra-doc
))
91 (setq geiser-impl--method-docs
92 (sort geiser-impl--method-docs
93 (lambda (a b
) (string< (symbol-name (car a
))
94 (symbol-name (car b
))))))
95 (put method
'function-documentation doc
)))
97 (defun geiser-implementation-help ()
98 "Shows a buffer with help on defining new supported Schemes."
100 (help-setup-xref (list #'geiser-implementation-help
) t
)
102 (with-help-window (help-buffer)
103 (princ "Geiser: supporting new Scheme implementations.\n\n")
104 (princ "Use `define-geiser-implementation' to define ")
105 (princ "new implementations")
106 (princ "\n\n (define-geiser-implementation NAME &rest METHODS)\n\n")
107 (princ (documentation 'define-geiser-implementation
))
108 (princ "\n\nMethods used to define an implementation:\n\n")
109 (dolist (m geiser-impl--method-docs
)
110 (let ((p (with-current-buffer (help-buffer) (point))))
111 (princ (format "%s: " (car m
)))
113 (with-current-buffer (help-buffer)
114 (fill-region-as-paragraph p
(point)))
116 (with-current-buffer standard-output
(buffer-string)))))
118 (defun geiser-impl--register-local-method (var-name method fallback doc
)
119 (add-to-list 'geiser-impl--local-methods
(list var-name method fallback
))
120 (geiser-impl--method-doc method doc var-name
)
121 (put var-name
'function-documentation doc
))
123 (defun geiser-impl--register-local-variable (var-name method fallback doc
)
124 (add-to-list 'geiser-impl--local-variables
(list var-name method fallback
))
125 (geiser-impl--method-doc method doc var-name
)
126 (put var-name
'variable-documentation doc
))
128 (defmacro geiser-impl--define-caller
(fun-name method arglist doc
)
129 (let ((impl (make-symbol "implementation-name")))
131 (defun ,fun-name
,(cons impl arglist
) ,doc
132 (geiser-impl--call-method ',method
,impl
,@arglist
))
133 (geiser-impl--method-doc ',method
,doc
',fun-name
))))
134 (put 'geiser-impl--define-caller
'lisp-indent-function
3)
136 (defun geiser-impl--register (file impl methods
)
137 (let ((current (assq impl geiser-impl--registry
)))
138 (if current
(setcdr current methods
)
139 (push (cons impl methods
) geiser-impl--registry
))
140 (push (cons impl file
) geiser-impl--load-files
)))
142 (defsubst geiser-activate-implementation
(impl)
143 (add-to-list 'geiser-active-implementations impl
))
145 (defsubst geiser-deactivate-implementation
(impl)
146 (setq geiser-active-implementations
147 (delq impl geiser-active-implementations
)))
149 (defsubst geiser-impl--active-p
(impl)
150 (memq impl geiser-active-implementations
))
153 ;;; Defining implementations:
155 (defun geiser-impl--normalize-method (m)
159 (if (functionp (cadr m
)) m
160 `(,(car m
) (lambda (&rest
) ,(cadr m
))))))
162 (defun geiser-impl--define (file name parent methods
)
163 (let* ((methods (mapcar 'geiser-impl--normalize-method methods
))
164 (methods (delq nil methods
))
165 (inherited-methods (and parent
(geiser-impl--methods parent
)))
166 (methods (append methods
167 (dolist (m methods inherited-methods
)
168 (setq inherited-methods
169 (assq-delete-all m inherited-methods
))))))
170 (geiser-impl--register file name methods
)))
172 (defmacro define-geiser-implementation
(name &rest methods
)
173 "Defines a new supported Scheme implementation.
174 NAME can be either an unquoted symbol naming the implementation,
175 or a two-element list (NAME PARENT), with PARENT naming another
176 registered implementation from which to borrow methods not
179 After NAME come the methods, each one a two element list of the
180 form (METHOD-NAME FUN-OR-VAR), where METHOD-NAME is one of the
181 needed methods (for a list, execute `geiser-implementation-help')
182 and a value, variable name or function name implementing it.
183 Omitted method names will return nil to their callers.
185 Here's how a typical call to this macro looks like:
187 (define-geiser-implementation guile
188 (binary geiser-guile--binary)
189 (arglist geiser-guile--parameters)
190 (repl-startup geiser-guile--startup)
191 (prompt-regexp geiser-guile--prompt-regexp)
192 (debugger-prompt-regexp geiser-guile--debugger-prompt-regexp)
193 (enter-debugger geiser-guile--enter-debugger)
194 (marshall-procedure geiser-guile--geiser-procedure)
195 (find-module geiser-guile--get-module)
196 (enter-command geiser-guile--enter-command)
197 (exit-command geiser-guile--exit-command)
198 (import-command geiser-guile--import-command)
199 (find-symbol-begin geiser-guile--symbol-begin)
200 (display-error geiser-guile--display-error)
202 (check-buffer geiser-guile--guess)
203 (keywords geiser-guile--keywords))
205 This macro also defines a runner function (run-NAME) and a
206 switcher (switch-to-NAME), and provides geiser-NAME."
207 (let ((name (if (listp name
) (car name
) name
))
208 (parent (and (listp name
) (cadr name
))))
209 (unless (symbolp name
)
210 (error "Malformed implementation name: %s" name
))
211 (let ((runner (intern (format "run-%s" name
)))
212 (switcher (intern (format "switch-to-%s" name
)))
213 (runner-doc (format "Start a new %s REPL." name
))
214 (switcher-doc (format "Switch to a running %s REPL, or start one."
216 (ask (make-symbol "ask")))
218 (geiser-impl--define ,load-file-name
',name
',parent
',methods
)
219 (require 'geiser-repl
)
220 (require 'geiser-menu
)
225 (defun ,switcher
(&optional
,ask
)
228 (switch-to-geiser ,ask
',name
))
229 (geiser-menu--add-impl ',name
',runner
',switcher
)
230 (provide ',(geiser-impl--feature name
))))))
232 (defun geiser-impl--add-to-alist (kind what impl
&optional append
)
233 (add-to-list 'geiser-implementations-alist
234 (list (list kind what
) impl
) append
))
237 ;;; Trying to guess the scheme implementation:
239 (make-variable-buffer-local
240 (defvar geiser-scheme-implementation nil
241 "Set this buffer local variable to specify the Scheme
242 implementation to be used by Geiser."))
244 (put 'geiser-scheme-implementation
'safe-local-variable
'symbolp
)
246 (defun geiser-impl--match-impl (desc bn
)
247 (let ((rx (if (eq (car desc
) 'regexp
)
249 (format "^%s" (regexp-quote (cadr desc
))))))
250 (and rx
(string-match-p rx bn
))))
252 (defvar geiser-impl--impl-prompt-history nil
)
254 (defun geiser-impl--read-impl (&optional prompt impls non-req
)
255 (let* ((impls (or impls geiser-active-implementations
))
256 (impls (mapcar 'symbol-name impls
))
257 (prompt (or prompt
"Scheme implementation: ")))
258 (intern (completing-read prompt impls nil
(not non-req
) nil
259 geiser-impl--impl-prompt-history
260 (and (car impls
) (car impls
))))))
262 (geiser-impl--define-caller geiser-impl--check-buffer check-buffer
()
263 "Method called without arguments that should check whether the current
264 buffer contains Scheme code of the given implementation.")
266 (defun geiser-impl--guess (&optional prompt
)
267 (or geiser-impl--implementation
268 (progn (hack-local-variables)
269 (and (memq geiser-scheme-implementation
270 geiser-active-implementations
)
271 geiser-scheme-implementation
))
272 (and (null (cdr geiser-active-implementations
))
273 (car geiser-active-implementations
))
275 (dolist (impl geiser-active-implementations
)
276 (when (geiser-impl--check-buffer impl
)
278 (let ((bn (buffer-file-name)))
280 (dolist (x geiser-implementations-alist
)
281 (when (and (memq (cadr x
) geiser-active-implementations
)
282 (geiser-impl--match-impl (car x
) bn
))
283 (throw 'impl
(cadr x
)))))))
284 geiser-default-implementation
285 (and prompt
(geiser-impl--read-impl))))
288 ;;; Using implementations:
290 (defsubst geiser-impl--registered-method
(impl method fallback
)
291 (let ((m (geiser-impl--method method impl
)))
293 (or fallback
(error "%s not defined for %s implementation"
296 (defsubst geiser-impl--registered-value
(impl method fallback
)
297 (let ((m (geiser-impl--method method impl
)))
298 (if (functionp m
) (funcall m
) fallback
)))
300 (defun geiser-impl--set-buffer-implementation (&optional impl prompt
)
301 (let ((impl (or impl
(geiser-impl--guess prompt
))))
303 (unless (geiser-impl--load-impl impl
)
304 (error "Cannot find %s implementation" impl
))
305 (setq geiser-impl--implementation impl
)
306 (dolist (m geiser-impl--local-methods
)
307 (set (make-local-variable (nth 0 m
))
308 (geiser-impl--registered-method impl
(nth 1 m
) (nth 2 m
))))
309 (dolist (m geiser-impl--local-variables
)
310 (set (make-local-variable (nth 0 m
))
311 (geiser-impl--registered-value impl
(nth 1 m
) (nth 2 m
)))))))
313 (defmacro with--geiser-implementation
(impl &rest body
)
314 (let* ((mbindings (mapcar (lambda (m)
316 (geiser-impl--registered-method ,impl
319 geiser-impl--local-methods
))
320 (vbindings (mapcar (lambda (m)
322 (geiser-impl--registered-value ,impl
325 geiser-impl--local-variables
))
326 (ibindings `((geiser-impl--implementation ,impl
)))
327 (bindings (append ibindings mbindings vbindings
)))
328 `(let* ,bindings
,@body
)))
329 (put 'with--geiser-implementation
'lisp-indent-function
1)
334 (defun geiser-impl-unload-function ()
335 (dolist (imp (mapcar (lambda (i)
336 (geiser-impl--feature (car i
)))
337 geiser-impl--registry
))
338 (when (featurep imp
) (unload-feature imp t
))))
341 (provide 'geiser-impl
)
345 ;; After providing 'geiser-impl, so that impls can use us.
346 (mapc 'geiser-impl--load-impl geiser-active-implementations
)
348 ;;; geiser-impl.el ends here