geiser-impl.el (14218B)
1 ;;; geiser-impl.el -- generic support for scheme implementations -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2009-2010, 2012-2013, 2015-2016, 2019, 2021-2022 Jose Antonio Ortega Ruiz 4 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>. 9 10 ;; Start date: Sat Mar 07, 2009 23:32 11 12 13 ;;; Code: 14 15 (require 'geiser-custom) 16 (require 'geiser-base) 17 18 (require 'help-fns) 19 20 21 ;;; Customization: 22 23 (defgroup geiser-implementation nil 24 "Generic support for multiple Scheme implementations." 25 :group 'geiser) 26 27 (geiser-custom--defcustom geiser-default-implementation nil 28 "Symbol naming the default Scheme implementation." 29 :type 'symbol) 30 31 ;;;###autoload (defvar geiser-active-implementations nil) 32 (geiser-custom--defcustom geiser-active-implementations () 33 "List of active installed Scheme implementations." 34 :type '(repeat symbol)) 35 36 ;;;###autoload (defvar geiser-implementations-alist nil) 37 (geiser-custom--defcustom geiser-implementations-alist nil 38 "A map from regular expressions or directories to implementations. 39 When opening a new file, its full path will be matched against 40 each one of the regular expressions or directories in this map 41 in order to determine its scheme flavour." 42 :type '(repeat (list (choice (group :tag "Regular expression" 43 (const regexp) regexp) 44 (group :tag "Directory" 45 (const dir) directory)) 46 symbol))) 47 48 49 ;;; Implementation registry: 50 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) 56 57 (geiser-custom--memoize 'geiser-impl--load-files) 58 59 (defvar-local geiser-impl--implementation nil) 60 61 (defsubst geiser-impl--impl-str (&optional impl) 62 (let ((impl (or impl geiser-impl--implementation))) 63 (and impl (capitalize (format "%s" impl))))) 64 65 (defsubst geiser-impl--feature (impl) 66 (intern (format "geiser-%s" impl))) 67 68 (defsubst geiser-impl--load-impl (impl) 69 (require (geiser-impl--feature impl) 70 (cdr (assq impl geiser-impl--load-files)) 71 t)) 72 73 (defsubst geiser-impl--methods (impl) 74 (cdr (assq impl geiser-impl--registry))) 75 76 (defun geiser-impl--method (method &optional impl) 77 (let ((impl (or impl 78 geiser-impl--implementation 79 geiser-default-implementation))) 80 (cadr (assq method (geiser-impl--methods impl))))) 81 82 (defun geiser-impl--default-method (method) 83 (cadr (assoc method (mapcar #'cdr geiser-impl--local-methods)))) 84 85 (defun geiser-impl--call-method (method impl &rest args) 86 (let ((fun (or (geiser-impl--method method impl) 87 (geiser-impl--default-method method)))) 88 (when (functionp fun) (apply fun args)))) 89 90 (defun geiser-impl--method-doc (method doc user) 91 (let* ((user (if user (format " Used via `%s'." user) "")) 92 (extra-doc (format "%s%s" doc user))) 93 (add-to-list 'geiser-impl--method-docs (cons method extra-doc)) 94 (setq geiser-impl--method-docs 95 (sort geiser-impl--method-docs 96 (lambda (a b) (string< (symbol-name (car a)) 97 (symbol-name (car b)))))) 98 (put method 'function-documentation doc))) 99 100 (defun geiser-implementation-help () 101 "Show a buffer with help on defining new supported Schemes." 102 (interactive) 103 (help-setup-xref (list #'geiser-implementation-help) t) 104 (save-excursion 105 (with-help-window (help-buffer) 106 (princ "Geiser: supporting new Scheme implementations.\n\n") 107 (princ "Use `define-geiser-implementation' to define ") 108 (princ "new implementations") 109 (princ "\n\n (define-geiser-implementation NAME &rest METHODS)\n\n") 110 (princ (documentation 'define-geiser-implementation)) 111 (princ "\n\nMethods used to define an implementation:\n\n") 112 (dolist (m geiser-impl--method-docs) 113 (let ((p (with-current-buffer (help-buffer) (point)))) 114 (princ (format "%s: " (car m))) 115 (princ (cdr m)) 116 (with-current-buffer (help-buffer) 117 (fill-region-as-paragraph p (point))) 118 (princ "\n\n"))) 119 (with-current-buffer standard-output (buffer-string))))) 120 121 (defun geiser-impl--register-local-method (var-name method fallback doc) 122 (add-to-list 'geiser-impl--local-methods (list var-name method fallback)) 123 (geiser-impl--method-doc method doc var-name) 124 (put var-name 'function-documentation doc)) 125 126 (defun geiser-impl--register-local-variable (var-name method fallback doc) 127 (add-to-list 'geiser-impl--local-variables (list var-name method fallback)) 128 (geiser-impl--method-doc method doc var-name) 129 (put var-name 'variable-documentation doc)) 130 131 (defmacro geiser-impl--define-caller (fun-name method arglist doc) 132 (let ((impl (make-symbol "implementation-name"))) 133 `(progn 134 (defun ,fun-name ,(cons impl arglist) ,doc 135 (geiser-impl--call-method ',method ,impl ,@arglist)) 136 (geiser-impl--method-doc ',method ,doc ',fun-name)))) 137 (put 'geiser-impl--define-caller 'lisp-indent-function 3) 138 139 (defun geiser-impl--register (file impl methods) 140 (let ((current (assq impl geiser-impl--registry))) 141 (if current (setcdr current methods) 142 (push (cons impl methods) geiser-impl--registry)) 143 (push (cons impl file) geiser-impl--load-files))) 144 145 ;;;###autoload 146 (progn ;Copy the whole def to the autoloads file. 147 (defun geiser-activate-implementation (impl) 148 (add-to-list 'geiser-active-implementations impl))) 149 150 (defsubst geiser-deactivate-implementation (impl) 151 (setq geiser-active-implementations 152 (delq impl geiser-active-implementations))) 153 154 (defsubst geiser-impl--active-p (impl) 155 (memq impl geiser-active-implementations)) 156 157 158 ;;; Defining implementations: 159 160 (defun geiser-impl--normalize-method (m) 161 (when (and (listp m) 162 (= 2 (length m)) 163 (symbolp (car m))) 164 (let ((v (cadr m))) 165 (if (functionp v) m `(,(car m) ,(lambda (&rest _) (eval v t))))))) 166 167 (defun geiser-impl--define (file name parent methods) 168 (let* ((methods (mapcar #'geiser-impl--normalize-method methods)) 169 (methods (delq nil methods)) 170 (inherited-methods (and parent (geiser-impl--methods parent))) 171 (methods (append methods 172 (dolist (m methods inherited-methods) 173 (setq inherited-methods 174 (assq-delete-all m inherited-methods)))))) 175 (geiser-impl--register file name methods))) 176 177 (defmacro define-geiser-implementation (name &rest methods) 178 "Define a new supported Scheme implementation. 179 NAME can be either an unquoted symbol naming the implementation, 180 or a two-element list (NAME PARENT), with PARENT naming another 181 registered implementation from which to borrow methods not 182 defined in METHODS. 183 184 After NAME come the methods, each one a two element list of the 185 form (METHOD-NAME FUN-OR-VAR), where METHOD-NAME is one of the 186 needed methods (for a list, execute `geiser-implementation-help') 187 and a value, variable name or function name implementing it. 188 Omitted method names will return nil to their callers. 189 190 Here's how a typical call to this macro looks like: 191 192 (define-geiser-implementation guile 193 (binary geiser-guile--binary) 194 (arglist geiser-guile--parameters) 195 (repl-startup geiser-guile--startup) 196 (prompt-regexp geiser-guile--prompt-regexp) 197 (debugger-prompt-regexp geiser-guile--debugger-prompt-regexp) 198 (enter-debugger geiser-guile--enter-debugger) 199 (marshall-procedure geiser-guile--geiser-procedure) 200 (find-module geiser-guile--get-module) 201 (enter-command geiser-guile--enter-command) 202 (exit-command geiser-guile--exit-command) 203 (import-command geiser-guile--import-command) 204 (find-symbol-begin geiser-guile--symbol-begin) 205 (display-error geiser-guile--display-error) 206 (display-help) 207 (check-buffer geiser-guile--guess) 208 (keywords geiser-guile--keywords) 209 (case-sensitive geiser-guile-case-sensitive-p)) 210 211 This macro also defines a runner function (geiser-NAME) and a 212 switcher (geiser-NAME-switch), and provides geiser-NAME." 213 (let ((name (if (listp name) (car name) name)) 214 (parent (and (listp name) (cadr name)))) 215 (unless (symbolp name) 216 (error "Malformed implementation name: %s" name)) 217 (let ((old-runner (intern (format "run-%s" name))) 218 (runner (intern (format "geiser-%s" name))) 219 (old-switcher (intern (format "switch-to-%s" name))) 220 (switcher (intern (format "geiser-%s-switch" name))) 221 (runner-doc (format "Start a new %s REPL." name)) 222 (switcher-doc (format "Switch to a running %s REPL, or start one." 223 name)) 224 (ask (gensym "ask"))) 225 `(progn 226 (geiser-impl--define load-file-name ',name ',parent ',methods) 227 (require 'geiser-repl) 228 (require 'geiser-menu) 229 (define-obsolete-function-alias ',old-runner ',runner "Geiser 0.26") 230 (defun ,runner () 231 ,runner-doc 232 (interactive) 233 (geiser ',name)) 234 (define-obsolete-function-alias ',old-switcher ',switcher "Geiser 0.26") 235 (defun ,switcher (&optional ,ask) 236 ,switcher-doc 237 (interactive "P") 238 (geiser-repl-switch ,ask ',name)) 239 (geiser-menu--add-impl ',name ',runner ',switcher))))) 240 241 ;;;###autoload 242 (progn 243 (defun geiser-impl--add-to-alist (kind what impl &optional append) 244 (add-to-list 'geiser-implementations-alist 245 (list (list kind what) impl) append)) 246 247 (defun geiser-implementation-extension (impl ext) 248 "Add to `geiser-implementations-alist' an entry for extension EXT." 249 (geiser-impl--add-to-alist 'regexp (format "\\.%s\\'" ext) impl t))) 250 251 252 ;;; Trying to guess the scheme implementation: 253 254 (defvar-local geiser-scheme-implementation nil 255 "The Scheme implementation to be used by Geiser.") 256 257 (put 'geiser-scheme-implementation 'safe-local-variable #'symbolp) 258 259 (defun geiser-impl--match-impl (desc bn) 260 (let ((rx (if (eq (car desc) 'regexp) 261 (cadr desc) 262 (format "^%s" (regexp-quote (cadr desc)))))) 263 (and rx (string-match-p rx bn)))) 264 265 (defvar geiser-impl--impl-prompt-history nil) 266 267 (defun geiser-impl--read-impl (&optional prompt impls non-req) 268 (let* ((impls (or impls geiser-active-implementations)) 269 (impls (mapcar #'symbol-name impls)) 270 (prompt (or prompt "Scheme implementation: "))) 271 (intern (completing-read prompt impls nil (not non-req) nil 272 geiser-impl--impl-prompt-history 273 (and (car impls) (car impls)))))) 274 275 (geiser-impl--define-caller geiser-impl--check-buffer check-buffer () 276 "Method called without arguments that should check whether the current 277 buffer contains Scheme code of the given implementation.") 278 279 (defun geiser-impl--guess (&optional prompt) 280 (or geiser-impl--implementation 281 (progn (hack-local-variables) 282 (and (geiser-impl--active-p geiser-scheme-implementation) 283 geiser-scheme-implementation)) 284 (and (null (cdr geiser-active-implementations)) 285 (car geiser-active-implementations)) 286 (catch 'impl 287 (dolist (impl geiser-active-implementations) 288 (when (geiser-impl--check-buffer impl) 289 (throw 'impl impl))) 290 (let ((bn (buffer-file-name))) 291 (when bn 292 (dolist (x geiser-implementations-alist) 293 (when (and (geiser-impl--active-p (cadr x)) 294 (geiser-impl--match-impl (car x) bn)) 295 (throw 'impl (cadr x))))))) 296 geiser-default-implementation 297 (and prompt (geiser-impl--read-impl)))) 298 299 300 ;;; Using implementations: 301 302 (defsubst geiser-impl--registered-method (impl method fallback) 303 (let ((m (geiser-impl--method method impl))) 304 (if (fboundp m) m 305 (or fallback (error "%s not defined for %s implementation" 306 method impl))))) 307 308 (defsubst geiser-impl--registered-value (impl method fallback) 309 (let ((m (geiser-impl--method method impl))) 310 (if (functionp m) (funcall m) fallback))) 311 312 (defun geiser-impl--set-buffer-implementation (&optional impl prompt) 313 (let ((impl (or impl (geiser-impl--guess prompt)))) 314 (when impl 315 (unless (geiser-impl--load-impl impl) 316 (error "Cannot find %s implementation" impl)) 317 (setq geiser-impl--implementation impl) 318 (dolist (m geiser-impl--local-methods) 319 (set (make-local-variable (nth 0 m)) 320 (geiser-impl--registered-method impl (nth 1 m) (nth 2 m)))) 321 (dolist (m geiser-impl--local-variables) 322 (set (make-local-variable (nth 0 m)) 323 (geiser-impl--registered-value impl (nth 1 m) (nth 2 m))))))) 324 325 (defmacro with--geiser-implementation (impl &rest body) 326 (declare (indent 1)) 327 (let* ((mbindings (mapcar (lambda (m) 328 `(,(nth 0 m) 329 (geiser-impl--registered-method ,impl 330 ',(nth 1 m) 331 ',(nth 2 m)))) 332 geiser-impl--local-methods)) 333 (vbindings (mapcar (lambda (m) 334 `(,(nth 0 m) 335 (geiser-impl--registered-value ,impl 336 ',(nth 1 m) 337 ',(nth 2 m)))) 338 geiser-impl--local-variables)) 339 (ibindings `((geiser-impl--implementation ,impl))) 340 (bindings (append ibindings mbindings vbindings))) 341 `(let* ,bindings ,@body))) 342 343 344 ;;; Reload support: 345 346 (defun geiser-impl-unload-function () 347 (dolist (imp (mapcar (lambda (i) 348 (geiser-impl--feature (car i))) 349 geiser-impl--registry)) 350 (when (featurep imp) (unload-feature imp t)))) 351 352 353 (provide 'geiser-impl) 354 ;;; geiser-impl.el ends here