mirror of https://github.com/Chizi123/.emacs.d.git

Chizi123
2018-11-21 e75a20334813452c6912c090d70a0de2c805f94d
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