elisp/geiser-impl.el

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