elisp/geiser-eval.el

   1 ;;; geiser-eval.el -- sending scheme code for evaluation
   2
   3 ;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2015 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 Feb 07, 2009 22:35
  11
  12 ;; Functions, building on top of geiser-connection, to evaluate scheme
  13 ;; code.
  14
  15 \f
  16
  17 (require 'geiser-impl)
  18 (require 'geiser-connection)
  19 (require 'geiser-syntax)
  20 (require 'geiser-log)
  21 (require 'geiser-base)
  22
  23 \f
  24 ;;; Plug-able functions:
  25
  26 (make-variable-buffer-local
  27  (defvar geiser-eval--get-module-function nil))
  28 (set-default 'geiser-eval--get-module-function nil)
  29
  30 (defvar geiser-eval--get-impl-module nil)
  31 (geiser-impl--register-local-method
  32  'geiser-eval--get-impl-module 'find-module '(lambda (&rest args) nil)
  33  "Function used to obtain the module for current buffer. It takes
  34 an optional argument, for cases where we want to force its
  35 value.")
  36
  37 (defun geiser-eval--get-module (&optional module)
  38   (if geiser-eval--get-module-function
  39       (funcall geiser-eval--get-module-function module)
  40     (funcall geiser-eval--get-impl-module module)))
  41
  42 (defvar geiser-eval--geiser-procedure-function)
  43 (geiser-impl--register-local-method
  44  'geiser-eval--geiser-procedure-function 'marshall-procedure 'identity
  45  "Function to translate a bare procedure symbol to one executable
  46 in the Scheme context. Return NULL for unsupported ones; at the
  47 very least, EVAL, COMPILE, LOAD-FILE and COMPILE-FILE should be
  48 supported.")
  49
  50 (defvar geiser-eval--unsupported nil)
  51 (geiser-impl--register-local-variable
  52  'geiser-eval--unsupported 'unsupported-procedures nil
  53  "A list, or function returning a list, of the Geiser procedures
  54 not implemented by this Scheme implementation. Possible values
  55 include macroexpand, completions, module-completions, find-file,
  56 symbol-location, module-location, symbol-documentation,
  57 module-exports, autodoc, callers, callees and generic-methods.")
  58
  59 (defun geiser-eval--supported-p (feat)
  60   (or (not geiser-eval--unsupported)
  61       (not (memq feat geiser-eval--unsupported))))
  62
  63 (defsubst geiser-eval--form (&rest args)
  64   (when (not (geiser-eval--supported-p (car args)))
  65     (error "Sorry, the %s scheme implementation does not support Geiser's %s"
  66            geiser-impl--implementation (car args)))
  67   (apply geiser-eval--geiser-procedure-function args))
  68
  69 \f
  70 ;;; Code formatting:
  71
  72 (defsubst geiser-eval--load-file (file)
  73   (geiser-eval--form 'load-file
  74                      (geiser-eval--scheme-str file)))
  75
  76 (defsubst geiser-eval--comp-file (file)
  77   (geiser-eval--form 'compile-file
  78                      (geiser-eval--scheme-str file)))
  79
  80 (defsubst geiser-eval--module (code)
  81   (geiser-eval--scheme-str
  82    (cond ((or (null code) (eq code :t) (eq code :buffer))
  83           (geiser-eval--get-module))
  84          ((or (eq code :repl) (eq code :f)) :f)
  85          (t (geiser-eval--get-module code)))))
  86
  87 (defsubst geiser-eval--eval (code)
  88   (geiser-eval--form 'eval
  89                      (geiser-eval--module (nth 1 code))
  90                      (geiser-eval--scheme-str (nth 0 code))))
  91
  92 (defsubst geiser-eval--comp (code)
  93   (geiser-eval--form 'compile
  94                      (geiser-eval--module (nth 1 code))
  95                      (geiser-eval--scheme-str (nth 0 code))))
  96
  97 (defsubst geiser-eval--ge (proc args)
  98   (apply 'geiser-eval--form (cons proc
  99                                   (mapcar 'geiser-eval--scheme-str args))))
 100
 101 (defun geiser-eval--scheme-str (code)
 102   (cond ((null code) "'()")
 103         ((eq code :f) "#f")
 104         ((eq code :t) "#t")
 105         ((listp code)
 106          (cond ((eq (car code) :eval) (geiser-eval--eval (cdr code)))
 107                ((eq (car code) :comp) (geiser-eval--comp (cdr code)))
 108                ((eq (car code) :load-file)
 109                 (geiser-eval--load-file (cadr code)))
 110                ((eq (car code) :comp-file)
 111                 (geiser-eval--comp-file (cadr code)))
 112                ((eq (car code) :module) (geiser-eval--module (cadr code)))
 113                ((eq (car code) :ge) (geiser-eval--ge (cadr code)
 114                                                      (cddr code)))
 115                ((eq (car code) :scm) (cadr code))
 116                (t (concat "("
 117                           (mapconcat 'geiser-eval--scheme-str code " ")
 118                           ")"))))
 119         ((symbolp code) (substring-no-properties (format "%s" code)))
 120         (t (substring-no-properties (format "%S" code)))))
 121
 122 \f
 123 ;;; Code sending:
 124
 125 (defvar geiser-eval--default-connection-function nil)
 126
 127 (defsubst geiser-eval--connection ()
 128   (and geiser-eval--default-connection-function
 129        (funcall geiser-eval--default-connection-function)))
 130
 131 (defsubst geiser-eval--log (s)
 132   (geiser-log--info "RETORT: %S" s)
 133   s)
 134
 135 (defsubst geiser-eval--code-str (code)
 136   (if (stringp code) code (geiser-eval--scheme-str code)))
 137
 138 (defsubst geiser-eval--send (code cont &optional buffer)
 139   (geiser-con--send-string (geiser-eval--connection)
 140                            (geiser-eval--code-str code)
 141                            cont
 142                            buffer))
 143
 144 (defvar geiser-eval--sync-retort nil)
 145 (defun geiser-eval--set-sync-retort (s)
 146   (setq geiser-eval--sync-retort (geiser-eval--log s)))
 147
 148 (defun geiser-eval--send/wait (code &optional timeout buffer)
 149   (setq geiser-eval--sync-retort nil)
 150   (geiser-con--send-string/wait (geiser-eval--connection)
 151                                 (geiser-eval--code-str code)
 152                                 'geiser-eval--set-sync-retort
 153                                 timeout
 154                                 buffer)
 155   geiser-eval--sync-retort)
 156
 157 \f
 158 ;;; Retort parsing:
 159
 160 (defsubst geiser-eval--retort-p (ret)
 161   (and (listp ret) (or (assoc 'error ret) (assoc 'result ret))))
 162
 163 (defsubst geiser-eval--retort-result (ret)
 164   (let ((values (cdr (assoc 'result ret))))
 165     (car (geiser-syntax--read-from-string (car values)))))
 166
 167 (defsubst geiser-eval--send/result (code &optional timeout buffer)
 168   (geiser-eval--retort-result (geiser-eval--send/wait code timeout buffer)))
 169
 170 (defun geiser-eval--retort-result-str (ret prefix)
 171   (let* ((prefix (or prefix "=> "))
 172          (nlprefix (concat "\n" prefix))
 173          (values (cdr (assoc 'result ret))))
 174     (if values
 175         (concat prefix (mapconcat 'identity values nlprefix))
 176       (or prefix "(No value)"))))
 177
 178 (defsubst geiser-eval--retort-output (ret)
 179   (cdr (assq 'output ret)))
 180
 181 (defsubst geiser-eval--retort-error (ret)
 182   (cdr (assq 'error ret)))
 183
 184 (defsubst geiser-eval--error-key (err)
 185   (cdr (assq 'key err)))
 186
 187 (defsubst geiser-eval--error-subr (err)
 188   (cdr (assq 'subr err)))
 189
 190 (defsubst geiser-eval--error-msg (err)
 191   (cdr (assq 'msg err)))
 192
 193 (defsubst geiser-eval--error-rest (err)
 194   (cdr (assq 'rest err)))
 195
 196 (defun geiser-eval--error-str (err)
 197   (let* ((key (geiser-eval--error-key err))
 198          (key-str (if key (format ": %s" key) ":"))
 199          (subr (geiser-eval--error-subr err))
 200          (subr-str (if subr (format " (%s):" subr) ""))
 201          (msg (geiser-eval--error-msg err))
 202          (msg-str (if msg (format "\n  %s" msg) ""))
 203          (rest (geiser-eval--error-rest err))
 204          (rest-str (if rest (format "\n  %s" rest) "")))
 205     (format "Error%s%s%s%s" subr-str key-str msg-str rest-str)))
 206
 207
 208 \f
 209 (provide 'geiser-eval)