| commit | author | age | ||
| 76bbd0 | 1 | ;;; ob-scheme.el --- Babel Functions for Scheme -*- lexical-binding: t; -*- |
| C | 2 | |
| 3 | ;; Copyright (C) 2010-2018 Free Software Foundation, Inc. | |
| 4 | ||
| 5 | ;; Authors: Eric Schulte | |
| 6 | ;; Michael Gauland | |
| 7 | ;; Keywords: literate programming, reproducible research, scheme | |
| 8 | ;; Homepage: https://orgmode.org | |
| 9 | ||
| 10 | ;; This file is part of GNU Emacs. | |
| 11 | ||
| 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
| 13 | ;; it under the terms of the GNU General Public License as published by | |
| 14 | ;; the Free Software Foundation, either version 3 of the License, or | |
| 15 | ;; (at your option) any later version. | |
| 16 | ||
| 17 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
| 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 20 | ;; GNU General Public License for more details. | |
| 21 | ||
| 22 | ;; You should have received a copy of the GNU General Public License | |
| 23 | ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | |
| 24 | ||
| 25 | ;;; Commentary: | |
| 26 | ||
| 27 | ;; Now working with SBCL for both session and external evaluation. | |
| 28 | ;; | |
| 29 | ;; This certainly isn't optimally robust, but it seems to be working | |
| 30 | ;; for the basic use cases. | |
| 31 | ||
| 32 | ;;; Requirements: | |
| 33 | ||
| 34 | ;; - a working scheme implementation | |
| 35 | ;; (e.g. guile https://www.gnu.org/software/guile/guile.html) | |
| 36 | ;; | |
| 37 | ;; - for session based evaluation geiser is required, which is available from | |
| 38 | ;; ELPA. | |
| 39 | ||
| 40 | ;;; Code: | |
| 41 | (require 'ob) | |
| 42 | (require 'geiser nil t) | |
| 43 | (require 'geiser-impl nil t) | |
| 44 | (defvar geiser-repl--repl) ; Defined in geiser-repl.el | |
| 45 | (defvar geiser-impl--implementation) ; Defined in geiser-impl.el | |
| 46 | (defvar geiser-default-implementation) ; Defined in geiser-impl.el | |
| 47 | (defvar geiser-active-implementations) ; Defined in geiser-impl.el | |
| 48 | (defvar geiser-debug-show-debug-p) ; Defined in geiser-debug.el | |
| 49 | (defvar geiser-debug-jump-to-debug-p) ; Defined in geiser-debug.el | |
| 50 | (defvar geiser-repl-use-other-window) ; Defined in geiser-repl.el | |
| 51 | (defvar geiser-repl-window-allow-split) ; Defined in geiser-repl.el | |
| 52 | ||
| 53 | (declare-function run-geiser "ext:geiser-repl" (impl)) | |
| 54 | (declare-function geiser-mode "ext:geiser-mode" ()) | |
| 55 | (declare-function geiser-eval-region "ext:geiser-mode" | |
| 56 | (start end &optional and-go raw nomsg)) | |
| 57 | (declare-function geiser-repl-exit "ext:geiser-repl" (&optional arg)) | |
| 58 | (declare-function geiser-eval--retort-output "ext:geiser-eval" (ret)) | |
| 59 | (declare-function geiser-eval--retort-result-str "ext:geiser-eval" (ret prefix)) | |
| 60 | ||
| 61 | (defcustom org-babel-scheme-null-to 'hline | |
| 62 | "Replace `null' and empty lists in scheme tables with this before returning." | |
| 63 | :group 'org-babel | |
| 64 | :version "26.1" | |
| 65 | :package-version '(Org . "9.1") | |
| 66 | :type 'symbol) | |
| 67 | ||
| 68 | (defvar org-babel-default-header-args:scheme '() | |
| 69 | "Default header arguments for scheme code blocks.") | |
| 70 | ||
| 71 | (defun org-babel-expand-body:scheme (body params) | |
| 72 | "Expand BODY according to PARAMS, return the expanded body." | |
| 73 | (let ((vars (org-babel--get-vars params)) | |
| 74 | (prepends (cdr (assq :prologue params)))) | |
| 75 | (concat (and prepends (concat prepends "\n")) | |
| 76 | (if (null vars) body | |
| 77 | (format "(let (%s)\n%s\n)" | |
| 78 | (mapconcat | |
| 79 | (lambda (var) | |
| 80 | (format "%S" (print `(,(car var) ',(cdr var))))) | |
| 81 | vars | |
| 82 | "\n ") | |
| 83 | body))))) | |
| 84 | ||
| 85 | ||
| 86 | (defvar org-babel-scheme-repl-map (make-hash-table :test #'equal) | |
| 87 | "Map of scheme sessions to session names.") | |
| 88 | ||
| 89 | (defun org-babel-scheme-cleanse-repl-map () | |
| 90 | "Remove dead buffers from the REPL map." | |
| 91 | (maphash | |
| 92 | (lambda (x y) (unless (buffer-name y) (remhash x org-babel-scheme-repl-map))) | |
| 93 | org-babel-scheme-repl-map)) | |
| 94 | ||
| 95 | (defun org-babel-scheme-get-session-buffer (session-name) | |
| 96 | "Look up the scheme buffer for a session; return nil if it doesn't exist." | |
| 97 | (org-babel-scheme-cleanse-repl-map) ; Prune dead sessions | |
| 98 | (gethash session-name org-babel-scheme-repl-map)) | |
| 99 | ||
| 100 | (defun org-babel-scheme-set-session-buffer (session-name buffer) | |
| 101 | "Record the scheme buffer used for a given session." | |
| 102 | (puthash session-name buffer org-babel-scheme-repl-map)) | |
| 103 | ||
| 104 | (defun org-babel-scheme-get-buffer-impl (buffer) | |
| 105 | "Returns the scheme implementation geiser associates with the buffer." | |
| 106 | (with-current-buffer (set-buffer buffer) | |
| 107 | geiser-impl--implementation)) | |
| 108 | ||
| 109 | (defun org-babel-scheme-get-repl (impl name) | |
| 110 | "Switch to a scheme REPL, creating it if it doesn't exist:" | |
| 111 | (let ((buffer (org-babel-scheme-get-session-buffer name))) | |
| 112 | (or buffer | |
| 113 | (progn | |
| 114 | (run-geiser impl) | |
| 115 | (if name | |
| 116 | (progn | |
| 117 | (rename-buffer name t) | |
| 118 | (org-babel-scheme-set-session-buffer name (current-buffer)))) | |
| 119 | (current-buffer))))) | |
| 120 | ||
| 121 | (defun org-babel-scheme-make-session-name (buffer name impl) | |
| 122 | "Generate a name for the session buffer. | |
| 123 | ||
| 124 | For a named session, the buffer name will be the session name. | |
| 125 | ||
| 126 | If the session is unnamed (nil), generate a name. | |
| 127 | ||
| 128 | If the session is `none', use nil for the session name, and | |
| 129 | org-babel-scheme-execute-with-geiser will use a temporary session." | |
| 130 | (cond ((not name) (concat buffer " " (symbol-name impl) " REPL")) | |
| 131 | ((string= name "none") nil) | |
| 132 | (name))) | |
| 133 | ||
| 134 | (defmacro org-babel-scheme-capture-current-message (&rest body) | |
| 135 | "Capture current message in both interactive and noninteractive mode" | |
| 136 | `(if noninteractive | |
| 137 | (let ((original-message (symbol-function 'message)) | |
| 138 | (current-message nil)) | |
| 139 | (unwind-protect | |
| 140 | (progn | |
| 141 | (defun message (&rest args) | |
| 142 | (setq current-message (apply original-message args))) | |
| 143 | ,@body | |
| 144 | current-message) | |
| 145 | (fset 'message original-message))) | |
| 146 | (progn | |
| 147 | ,@body | |
| 148 | (current-message)))) | |
| 149 | ||
| 150 | (defun org-babel-scheme-execute-with-geiser (code output impl repl) | |
| 151 | "Execute code in specified REPL. If the REPL doesn't exist, create it | |
| 152 | using the given scheme implementation. | |
| 153 | ||
| 154 | Returns the output of executing the code if the output parameter | |
| 155 | is true; otherwise returns the last value." | |
| 156 | (let ((result nil)) | |
| 157 | (with-temp-buffer | |
| 158 | (insert (format ";; -*- geiser-scheme-implementation: %s -*-" impl)) | |
| 159 | (newline) | |
| 160 | (insert code) | |
| 161 | (geiser-mode) | |
| 162 | (let ((geiser-repl-window-allow-split nil) | |
| 163 | (geiser-repl-use-other-window nil)) | |
| 164 | (let ((repl-buffer (save-current-buffer | |
| 165 | (org-babel-scheme-get-repl impl repl)))) | |
| 166 | (when (not (eq impl (org-babel-scheme-get-buffer-impl | |
| 167 | (current-buffer)))) | |
| 168 | (message "Implementation mismatch: %s (%s) %s (%s)" impl (symbolp impl) | |
| 169 | (org-babel-scheme-get-buffer-impl (current-buffer)) | |
| 170 | (symbolp (org-babel-scheme-get-buffer-impl | |
| 171 | (current-buffer))))) | |
| 172 | (setq geiser-repl--repl repl-buffer) | |
| 173 | (setq geiser-impl--implementation nil) | |
| 174 | (let ((geiser-debug-jump-to-debug-p nil) | |
| 175 | (geiser-debug-show-debug-p nil)) | |
| 176 | (let ((ret (geiser-eval-region (point-min) (point-max)))) | |
| 177 | (setq result (if output | |
| 178 | (geiser-eval--retort-output ret) | |
| 179 | (geiser-eval--retort-result-str ret ""))))) | |
| 180 | (when (not repl) | |
| 181 | (save-current-buffer (set-buffer repl-buffer) | |
| 182 | (geiser-repl-exit)) | |
| 183 | (set-process-query-on-exit-flag (get-buffer-process repl-buffer) nil) | |
| 184 | (kill-buffer repl-buffer))))) | |
| 185 | result)) | |
| 186 | ||
| 187 | (defun org-babel-scheme--table-or-string (results) | |
| 188 | "Convert RESULTS into an appropriate elisp value. | |
| 189 | If the results look like a list or tuple, then convert them into an | |
| 190 | Emacs-lisp table, otherwise return the results as a string." | |
| 191 | (let ((res (org-babel-script-escape results))) | |
| 192 | (cond ((listp res) | |
| 193 | (mapcar (lambda (el) | |
| 194 | (if (or (null el) (eq el 'null)) | |
| 195 | org-babel-scheme-null-to | |
| 196 | el)) | |
| 197 | res)) | |
| 198 | (t res)))) | |
| 199 | ||
| 200 | (defun org-babel-execute:scheme (body params) | |
| 201 | "Execute a block of Scheme code with org-babel. | |
| 202 | This function is called by `org-babel-execute-src-block'" | |
| 203 | (let* ((source-buffer (current-buffer)) | |
| 204 | (source-buffer-name (replace-regexp-in-string ;; zap surrounding * | |
| 205 | "^ ?\\*\\([^*]+\\)\\*" "\\1" | |
| 206 | (buffer-name source-buffer)))) | |
| 207 | (save-excursion | |
| 208 | (let* ((result-type (cdr (assq :result-type params))) | |
| 209 | (impl (or (when (cdr (assq :scheme params)) | |
| 210 | (intern (cdr (assq :scheme params)))) | |
| 211 | geiser-default-implementation | |
| 212 | (car geiser-active-implementations))) | |
| 213 | (session (org-babel-scheme-make-session-name | |
| 214 | source-buffer-name (cdr (assq :session params)) impl)) | |
| 215 | (full-body (org-babel-expand-body:scheme body params)) | |
| 216 | (result | |
| 217 | (org-babel-scheme-execute-with-geiser | |
| 218 | full-body ; code | |
| 219 | (string= result-type "output") ; output? | |
| 220 | impl ; implementation | |
| 221 | (and (not (string= session "none")) session)))) ; session | |
| 222 | (let ((table | |
| 223 | (org-babel-reassemble-table | |
| 224 | result | |
| 225 | (org-babel-pick-name (cdr (assq :colname-names params)) | |
| 226 | (cdr (assq :colnames params))) | |
| 227 | (org-babel-pick-name (cdr (assq :rowname-names params)) | |
| 228 | (cdr (assq :rownames params)))))) | |
| 229 | (org-babel-scheme--table-or-string table)))))) | |
| 230 | ||
| 231 | (provide 'ob-scheme) | |
| 232 | ||
| 233 | ;;; ob-scheme.el ends here | |
