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