elisp/geiser-impl.el

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