elisp/geiser-eval.el

   1 ;;; geiser-eval.el -- sending scheme code for evaluation
   2
   3 ;; Copyright (C) 2009, 2010, 2011, 2012 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) 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--eval (code)
  73   (geiser-eval--form 'eval
  74                      (geiser-eval--module (nth 1 code))
  75                      (geiser-eval--scheme-str (nth 0 code))))
  76
  77 (defsubst geiser-eval--comp (code)
  78   (geiser-eval--form 'compile
  79                      (geiser-eval--module (nth 1 code))
  80                      (geiser-eval--scheme-str (nth 0 code))))
  81
  82 (defsubst geiser-eval--load-file (file)
  83   (geiser-eval--form 'load-file
  84                      (geiser-eval--scheme-str file)))
  85
  86 (defsubst geiser-eval--comp-file (file)
  87   (geiser-eval--form 'compile-file
  88                      (geiser-eval--scheme-str file)))
  89
  90 (defsubst geiser-eval--module (code)
  91   (geiser-eval--scheme-str
  92    (cond ((or (null code) (eq code :t) (eq code :buffer))
  93           (geiser-eval--get-module))
  94          ((or (eq code :repl) (eq code :f)) :f)
  95          (t (geiser-eval--get-module 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 (defsubst geiser-eval--send/result (code &optional timeout buffer)
 158   (geiser-eval--retort-result (geiser-eval--send/wait code timeout buffer)))
 159
 160 \f
 161 ;;; Retort parsing:
 162
 163 (defsubst geiser-eval--retort-p (ret)
 164   (and (listp ret) (or (assoc 'error ret) (assoc 'result ret))))
 165
 166 (defsubst geiser-eval--retort-result (ret)
 167   (let ((values (cdr (assoc 'result ret))))
 168     (car (geiser-syntax--read-from-string (car values)))))
 169
 170 (defun geiser-eval--retort-result-str (ret)
 171   (let ((values (cdr (assoc 'result ret))))
 172     (if values
 173         (concat "=> " (mapconcat 'identity values "\n=> "))
 174       "(No value)")))
 175
 176 (defsubst geiser-eval--retort-output (ret) (cdr (assoc 'output ret)))
 177 (defsubst geiser-eval--retort-error (ret) (cdr (assoc 'error ret)))
 178
 179 (defsubst geiser-eval--error-key (err) (cdr (assoc 'key err)))
 180 (defsubst geiser-eval--error-subr (err) (cdr (assoc 'subr err)))
 181 (defsubst geiser-eval--error-msg (err) (cdr (assoc 'msg err)))
 182 (defsubst geiser-eval--error-rest (err) (cdr (assoc 'rest err)))
 183
 184 (defun geiser-eval--error-str (err)
 185   (let* ((key (geiser-eval--error-key err))
 186          (key-str (if key (format ": %s" key) ":"))
 187          (subr (geiser-eval--error-subr err))
 188          (subr-str (if subr (format " (%s):" subr) ""))
 189          (msg (geiser-eval--error-msg err))
 190          (msg-str (if msg (format "\n  %s" msg) ""))
 191          (rest (geiser-eval--error-rest err))
 192          (rest-str (if rest (format "\n  %s" rest) "")))
 193     (format "Error%s%s%s%s" subr-str key-str msg-str rest-str)))
 194
 195
 196 \f
 197 (provide 'geiser-eval)