2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4 ;; MODULE : plugin-eval.scm
5 ;; DESCRIPTION : Evaluation via plugins
6 ;; COPYRIGHT : (C) 1999-2009 Joris van der Hoeven
8 ;; This software falls under the GNU general public license version 3 or later.
9 ;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
10 ;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
14 (texmacs-module (utils plugins plugin-eval)
15 (:use (utils library tree)
16 (utils library cursor)))
18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
19 ;; evaluation + simplification of document fragments
20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
22 (tm-define (plugin-output-std-simplify name t)
23 (cond ((or (func? t 'document 0) (func? 'concat 0)) "")
24 ((or (func? t 'document 1) (func? t 'concat 1))
25 (plugin-output-simplify name (cadr t)))
26 ((and (or (func? t 'document) (func? t 'concat))
27 (in? (cadr t) '("" " " " ")))
28 (plugin-output-simplify name (cons (car t) (cddr t))))
29 ((and (or (func? t 'document) (func? t 'concat))
30 (in? (cAr t) '("" " " " ")))
31 (plugin-output-simplify name (cDr t)))
32 ((match? t '(with "mode" "math" :%1))
33 `(math ,(plugin-output-simplify name (cAr t))))
35 (rcons (cDr t) (plugin-output-simplify name (cAr t))))
38 (tm-define (plugin-output-simplify name t)
39 (plugin-output-std-simplify name t))
41 (tm-define (plugin-preprocess name ses t opts)
42 ;;(display* "Preprocess " t "\n")
45 (if (and (== (car opts) :math-input)
46 (plugin-supports-math-input-ref name))
47 (set! t (plugin-math-input (list 'tuple name t))))
48 (plugin-preprocess name ses t (cdr opts)))))
50 (tm-define (plugin-postprocess name ses r opts)
51 ;;(display* "Postprocess " r "\n")
54 (if (== (car opts) :simplify-output)
55 (set! r (plugin-output-simplify name r)))
56 (plugin-postprocess name ses r (cdr opts)))))
58 (tm-define (plugin-eval name ses t . opts)
59 (with u (plugin-preprocess name ses t opts)
60 ;;(display* "u= " u "\n")
61 (with r (tree->stree (connection-eval name ses u))
62 ;;(display* "r= " r "\n")
63 (plugin-postprocess name ses r (cons :simplify-output opts)))))
65 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
66 ;; New connection management
67 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
69 (define plugin-pending (make-ahash-table))
70 (define plugin-started (make-ahash-table))
71 (define plugin-prompts (make-ahash-table))
72 (define plugin-author (make-ahash-table))
74 (define (pending-set lan ses l)
75 (ahash-set! plugin-pending (list lan ses) l))
77 (tm-define (pending-ref lan ses)
78 (or (ahash-ref plugin-pending (list lan ses)) '()))
80 (define (plugin-status lan ses)
82 (connection-status lan ses)
85 (define (plugin-set-author lan ses)
86 (with l (pending-ref lan ses)
88 (ahash-set! plugin-author (list lan ses) (fifth (caar l))))))
90 (define (plugin-start lan ses)
91 (when (!= lan "scheme")
92 (plugin-set-author lan ses)
93 (connection-start lan ses)))
95 (tm-define (plugin-write lan ses t)
96 (ahash-set! plugin-started (list lan ses) (texmacs-time))
99 (connection-write-string lan ses t)
101 (plugin-set-author lan ses)
102 (connection-write lan ses t)))
104 (connection-notify-status lan ses 3)
105 (with r (scheme-eval t)
106 (if (not (func? r 'document))
107 (set! r (tree 'document r)))
108 (connection-notify lan ses "output" r))
109 (connection-notify-status lan ses 2))))
111 (define (plugin-do lan ses)
112 (with l (pending-ref lan ses)
114 (with status (plugin-status lan ses)
115 (cond ((and (> (length (car l)) 2) (== (second (car l)) :start))
117 (plugin-start lan ses)
118 (plugin-next lan ses)))
121 (when (!= lan "scheme")
122 (set! author (new-author))
123 (start-slave author))
124 (with p (silent-encode :start noop '())
125 (set! p (cons (rcons (car p) author) (cdr p)))
126 (pending-set lan ses (cons p l))
127 (plugin-do lan ses))))
129 ((first (caar l)) lan ses)))))))
131 (tm-define (plugin-next lan ses)
132 (with l (pending-ref lan ses)
134 ((third (caar l)) lan ses)
135 (pending-set lan ses (cdr l))
136 (plugin-do lan ses))))
138 (define (plugin-cancel lan ses dead?)
139 (with l (pending-ref lan ses)
141 ((fourth (caar l)) lan ses dead?)
142 (pending-set lan ses (cdr l))
143 (plugin-cancel lan ses dead?))))
145 (tm-define (plugin-prompt lan ses)
146 (with p (ahash-ref plugin-prompts (list lan ses))
147 (if p (tree-copy p) (string-append (upcase-first lan) "] "))))
149 (tm-define (plugin-timing lan ses)
150 (with t (ahash-ref plugin-started (list lan ses))
151 (if t (- (texmacs-time) t) 0)))
153 (tm-define (plugin-feed lan ses do notify next cancel args)
154 (with l (pending-ref lan ses)
156 (when (!= lan "scheme")
157 (set! author (new-author))
158 (start-slave author))
159 (with cb (list do notify next cancel author)
160 (pending-set lan ses (rcons l (cons cb args)))
161 (if (null? l) (plugin-do lan ses))))))
163 (tm-define (plugin-interrupt)
164 (let* ((lan (get-env "prog-language"))
165 (ses (get-env "prog-session")))
166 (if (== (connection-status lan ses) 3)
167 (connection-interrupt lan ses))
168 (plugin-cancel lan ses #f)))
170 (tm-define (plugin-stop)
171 (let* ((lan (get-env "prog-language"))
172 (ses (get-env "prog-session")))
173 (if (!= (connection-status lan ses) 0)
174 (connection-stop lan ses))))
176 (define-public-macro (with-author a . body)
179 (with old (get-author)
181 (with r (begin ,@body)
186 (tm-define (connection-notify lan ses ch t)
187 ;;(display* "Notify " lan ", " ses ", " ch ", " t "\n")
188 (with-author (ahash-ref plugin-author (list lan ses))
189 (with l (pending-ref lan ses)
192 (ahash-set! plugin-prompts (list lan ses) (tree-copy t)))
193 ((second (caar l)) lan ses ch t)))))
195 (tm-define (connection-notify-status lan ses st)
196 ;;(display* "Notify status " lan ", " ses ", " st "\n")
197 (with-author (ahash-ref plugin-author (list lan ses))
199 (ahash-remove! plugin-started (list lan ses))
200 (ahash-remove! plugin-prompts (list lan ses))
201 (plugin-cancel lan ses #t))
203 (plugin-next lan ses))))
205 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
207 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
209 (define (silent-encode in return opts)
210 (list (list silent-do silent-notify silent-next silent-cancel)
211 (if (tm? in) (tm->stree in) in)
217 (define (silent-decode l)
224 (define (silent-do lan ses)
225 (with l (pending-ref lan ses)
226 (with (in out err return opts) (silent-decode (car l))
227 ;;(display* "Silent do " lan ", " ses ", " in "\n")
229 (plugin-next lan ses)
230 (plugin-write lan ses in)))))
232 (define (silent-next lan ses)
233 ;;(display* "Silent next " lan ", " ses "\n")
234 (with l (pending-ref lan ses)
235 (with (in out err return opts) (silent-decode (car l))
236 (return (cons (tm->stree out) (tm->stree err))))))
238 (define (var-tree-children t)
239 (with r (tree-children t)
240 (if (and (nnull? r) (tree-empty? (cAr r))) (cDr r) r)))
242 (define (silent-output t u)
243 (when (and (tm-func? t 'document) (tm-func? u 'document))
244 (tree-insert! t (tree-arity t) (var-tree-children u))))
246 (define (silent-notify lan ses ch t)
247 ;;(display* "Silent notify " lan ", " ses ", " ch ", " t "\n")
248 (with l (pending-ref lan ses)
249 (with (in out err return opts) (silent-decode (car l))
250 (cond ((== ch "output")
251 (silent-output out t))
253 (silent-output err t))))))
255 (define (silent-cancel lan ses dead?)
256 ;;(display* "Silent cancel " lan ", " ses ", " dead? "\n")
257 (with l (pending-ref lan ses)
258 (with (in out err return opts) (silent-decode (car l))
259 (return (if dead? :dead :interrupted)))))
261 (tm-define (silent-feed lan ses in return opts)
262 (set! in (plugin-preprocess lan ses in opts))
263 (with ret (lambda (x)
264 (return (if (npair? x) x
265 (cons (plugin-postprocess lan ses (car x) opts)
266 (plugin-postprocess lan ses (cdr x) opts)))))
267 (with x (silent-encode in ret opts)
268 (apply plugin-feed `(,lan ,ses ,@(car x) ,(cdr x))))))
270 (tm-define (silent-feed* lan ses in return opts)
271 (with ret (lambda (x)
272 (return (cond ((== x :dead) '(script-dead))
273 ((== x :interrupted) '(script-interrupted))
274 ((!= (tm-arity (cdr x)) 0)
275 `(with "color" "red" ,(cdr x)))
277 (silent-feed lan ses in ret opts)))
279 (define (plugin-command-answer x)
280 (if (tm-func? x 'document 1) (plugin-command-answer (cadr x))
283 (tm-define (plugin-command lan ses in return opts)
284 (let* ((cmd (format-command lan in))
285 (ret (lambda (x) (return (plugin-command-answer (car x)))))
286 (x (silent-encode cmd ret opts)))
287 (apply plugin-feed `(,lan ,ses ,@(car x) ,(cdr x)))))