lisp/org/ob-scheme.el

   1 ;;; ob-scheme.el --- org-babel functions for Scheme
   2
   3 ;; Copyright (C) 2010-2014 Free Software Foundation, Inc.
   4
   5 ;; Authors: Eric Schulte, Michael Gauland
   6 ;; Keywords: literate programming, reproducible research, scheme
   7 ;; Homepage: http://orgmode.org
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; Now working with SBCL for both session and external evaluation.
  27 ;;
  28 ;; This certainly isn't optimally robust, but it seems to be working
  29 ;; for the basic use cases.
  30
  31 ;;; Requirements:
  32
  33 ;; - a working scheme implementation
  34 ;;   (e.g. guile http://www.gnu.org/software/guile/guile.html)
  35 ;;
  36 ;; - for session based evaluation geiser is required, which is available from
  37 ;;   ELPA.
  38
  39 ;;; Code:
  40 (require 'ob)
  41 (require 'geiser nil t)
  42 (defvar geiser-repl--repl)             ; Defined in geiser-repl.el
  43 (defvar geiser-impl--implementation)   ; Defined in geiser-impl.el
  44 (defvar geiser-default-implementation) ; Defined in geiser-impl.el
  45 (defvar geiser-active-implementations) ; Defined in geiser-impl.el
  46
  47 (declare-function run-geiser "geiser-repl" (impl))
  48 (declare-function geiser-mode "geiser-mode" ())
  49 (declare-function geiser-eval-region "geiser-mode" (start end &optional and-go raw nomsg))
  50 (declare-function geiser-repl-exit "geiser-repl" (&optional arg))
  51
  52 (defvar org-babel-default-header-args:scheme '()
  53   "Default header arguments for scheme code blocks.")
  54
  55 (defun org-babel-expand-body:scheme (body params)
  56   "Expand BODY according to PARAMS, return the expanded body."
  57   (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
  58     (if (> (length vars) 0)
  59         (concat "(let ("
  60                 (mapconcat
  61                  (lambda (var) (format "%S" (print `(,(car var) ',(cdr var)))))
  62                  vars "\n      ")
  63                 ")\n" body ")")
  64       body)))
  65
  66
  67 (defvar org-babel-scheme-repl-map (make-hash-table :test 'equal)
  68   "Map of scheme sessions to session names.")
  69
  70 (defun org-babel-scheme-cleanse-repl-map ()
  71   "Remove dead buffers from the REPL map."
  72   (maphash
  73    (lambda (x y)
  74      (when (not (buffer-name y))
  75        (remhash x org-babel-scheme-repl-map)))
  76    org-babel-scheme-repl-map))
  77
  78 (defun org-babel-scheme-get-session-buffer (session-name)
  79   "Look up the scheme buffer for a session; return nil if it doesn't exist."
  80   (org-babel-scheme-cleanse-repl-map) ; Prune dead sessions
  81   (gethash session-name org-babel-scheme-repl-map))
  82
  83 (defun org-babel-scheme-set-session-buffer (session-name buffer)
  84   "Record the scheme buffer used for a given session."
  85   (puthash session-name buffer org-babel-scheme-repl-map))
  86
  87 (defun org-babel-scheme-get-buffer-impl (buffer)
  88   "Returns the scheme implementation geiser associates with the buffer."
  89   (with-current-buffer (set-buffer buffer)
  90     geiser-impl--implementation))
  91
  92 (defun org-babel-scheme-get-repl (impl name)
  93   "Switch to a scheme REPL, creating it if it doesn't exist:"
  94   (let ((buffer (org-babel-scheme-get-session-buffer name)))
  95     (or buffer
  96         (progn
  97           (run-geiser impl)
  98           (if name
  99               (progn
 100                 (rename-buffer name t)
 101                 (org-babel-scheme-set-session-buffer name (current-buffer))))
 102           (current-buffer)))))
 103
 104 (defun org-babel-scheme-make-session-name (buffer name impl)
 105   "Generate a name for the session buffer.
 106
 107 For a named session, the buffer name will be the session name.
 108
 109 If the session is unnamed (nil), generate a name.
 110
 111 If the session is 'none', use nil for the session name, and
 112 org-babel-scheme-execute-with-geiser will use a temporary session."
 113   (let ((result
 114          (cond ((not name)
 115                 (concat buffer " " (symbol-name impl) " REPL"))
 116                ((string= name "none") nil)
 117                (name))))
 118     result))
 119
 120 (defun org-babel-scheme-execute-with-geiser (code output impl repl)
 121   "Execute code in specified REPL. If the REPL doesn't exist, create it
 122 using the given scheme implementation.
 123
 124 Returns the output of executing the code if the output parameter
 125 is true; otherwise returns the last value."
 126   (let ((result nil))
 127     (with-temp-buffer
 128       (insert (format ";; -*- geiser-scheme-implementation: %s -*-" impl))
 129       (newline)
 130       (insert (if output
 131                   (format "(with-output-to-string (lambda () %s))" code)
 132                 code))
 133       (geiser-mode)
 134       (let ((repl-buffer (save-current-buffer
 135                            (org-babel-scheme-get-repl impl repl))))
 136         (when (not (eq impl (org-babel-scheme-get-buffer-impl
 137                              (current-buffer))))
 138           (message "Implementation mismatch: %s (%s) %s (%s)" impl (symbolp impl)
 139                    (org-babel-scheme-get-buffer-impl (current-buffer))
 140                    (symbolp (org-babel-scheme-get-buffer-impl
 141                              (current-buffer)))))
 142         (setq geiser-repl--repl repl-buffer)
 143         (setq geiser-impl--implementation nil)
 144         (geiser-eval-region (point-min) (point-max))
 145         (setq result
 146               (if (equal (substring (current-message) 0 3) "=> ")
 147                   (replace-regexp-in-string "^=> " "" (current-message))
 148                 "\"An error occurred.\""))
 149         (when (not repl)
 150           (save-current-buffer (set-buffer repl-buffer)
 151                                (geiser-repl-exit))
 152           (set-process-query-on-exit-flag (get-buffer-process repl-buffer) nil)
 153           (kill-buffer repl-buffer))
 154         (setq result (if (or (string= result "#<void>")
 155                              (string= result "#<unspecified>"))
 156                          nil
 157                        (read result)))))
 158     result))
 159
 160 (defun org-babel-execute:scheme (body params)
 161   "Execute a block of Scheme code with org-babel.
 162 This function is called by `org-babel-execute-src-block'"
 163   (let* ((source-buffer (current-buffer))
 164          (source-buffer-name (replace-regexp-in-string ;; zap surrounding *
 165                               "^ ?\\*\\([^*]+\\)\\*" "\\1"
 166                               (buffer-name source-buffer))))
 167     (save-excursion
 168       (org-babel-reassemble-table
 169        (let* ((result-type (cdr (assoc :result-type params)))
 170               (impl (or (when (cdr (assoc :scheme params))
 171                           (intern (cdr (assoc :scheme params))))
 172                         geiser-default-implementation
 173                         (car geiser-active-implementations)))
 174               (session (org-babel-scheme-make-session-name
 175                         source-buffer-name (cdr (assoc :session params)) impl))
 176               (full-body (org-babel-expand-body:scheme body params)))
 177          (org-babel-scheme-execute-with-geiser
 178           full-body                      ; code
 179           (string= result-type "output") ; output?
 180           impl                           ; implementation
 181           (and (not (string= session "none")) session))) ; session
 182        (org-babel-pick-name (cdr (assoc :colname-names params))
 183                             (cdr (assoc :colnames params)))
 184        (org-babel-pick-name (cdr (assoc :rowname-names params))
 185                             (cdr (assoc :rownames params)))))))
 186
 187 (provide 'ob-scheme)
 188
 189 ;;; ob-scheme.el ends here