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 (plugin-set-author lan ses)
100 (connection-write lan ses t))
102 (connection-notify-status lan ses 3)
103 (with r (scheme-eval t)
104 (if (not (func? r 'document))
105 (set! r (tree 'document r)))
106 (connection-notify lan ses "output" r))
107 (connection-notify-status lan ses 2))))
109 (define (plugin-do lan ses)
110 (with l (pending-ref lan ses)
112 (with status (plugin-status lan ses)
113 (cond ((and (> (length (car l)) 2) (== (second (car l)) :start))
115 (plugin-start lan ses)
116 (plugin-next lan ses)))
119 (when (!= lan "scheme")
120 (set! author (new-author))
121 (start-slave author))
122 (with p (silent-encode :start noop '())
123 (set! p (cons (rcons (car p) author) (cdr p)))
124 (pending-set lan ses (cons p l))
125 (plugin-do lan ses))))
127 ((first (caar l)) lan ses)))))))
129 (tm-define (plugin-next lan ses)
130 (with l (pending-ref lan ses)
132 ((third (caar l)) lan ses)
133 (pending-set lan ses (cdr l))
134 (plugin-do lan ses))))
136 (define (plugin-cancel lan ses dead?)
137 (with l (pending-ref lan ses)
139 ((fourth (caar l)) lan ses dead?)
140 (pending-set lan ses (cdr l))
141 (plugin-cancel lan ses dead?))))
143 (tm-define (plugin-prompt lan ses)
144 (with p (ahash-ref plugin-prompts (list lan ses))
145 (if p (tree-copy p) (string-append (upcase-first lan) "] "))))
147 (tm-define (plugin-timing lan ses)
148 (with t (ahash-ref plugin-started (list lan ses))
149 (if t (- (texmacs-time) t) 0)))
151 (tm-define (plugin-feed lan ses do notify next cancel args)
152 (with l (pending-ref lan ses)
154 (when (!= lan "scheme")
155 (set! author (new-author))
156 (start-slave author))
157 (with cb (list do notify next cancel author)
158 (pending-set lan ses (rcons l (cons cb args)))
159 (if (null? l) (plugin-do lan ses))))))
161 (tm-define (plugin-interrupt)
162 (let* ((lan (get-env "prog-language"))
163 (ses (get-env "prog-session")))
164 (if (== (connection-status lan ses) 3)
165 (connection-interrupt lan ses))
166 (plugin-cancel lan ses #f)))
168 (tm-define (plugin-stop)
169 (let* ((lan (get-env "prog-language"))
170 (ses (get-env "prog-session")))
171 (if (!= (connection-status lan ses) 0)
172 (connection-stop lan ses))))
174 (define-public-macro (with-author a . body)
177 (with old (get-author)
179 (with r (begin ,@body)
184 (tm-define (connection-notify lan ses ch t)
185 ;;(display* "Notify " lan ", " ses ", " ch ", " t "\n")
186 (with-author (ahash-ref plugin-author (list lan ses))
187 (with l (pending-ref lan ses)
190 (ahash-set! plugin-prompts (list lan ses) (tree-copy t)))
191 ((second (caar l)) lan ses ch t)))))
193 (tm-define (connection-notify-status lan ses st)
194 ;;(display* "Notify status " lan ", " ses ", " st "\n")
195 (with-author (ahash-ref plugin-author (list lan ses))
197 (ahash-remove! plugin-started (list lan ses))
198 (ahash-remove! plugin-prompts (list lan ses))
199 (plugin-cancel lan ses #t))
201 (plugin-next lan ses))))
203 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
205 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
207 (define (silent-encode in return opts)
208 (list (list silent-do silent-notify silent-next silent-cancel)
209 (if (tm? in) (tm->stree in) in)
215 (define (silent-decode l)
222 (define (silent-do lan ses)
223 (with l (pending-ref lan ses)
224 (with (in out err return opts) (silent-decode (car l))
225 ;;(display* "Silent do " lan ", " ses ", " in "\n")
227 (plugin-next lan ses)
228 (plugin-write lan ses in)))))
230 (define (silent-next lan ses)
231 ;;(display* "Silent next " lan ", " ses "\n")
232 (with l (pending-ref lan ses)
233 (with (in out err return opts) (silent-decode (car l))
234 (return (cons (tm->stree out) (tm->stree err))))))
236 (define (var-tree-children t)
237 (with r (tree-children t)
238 (if (and (nnull? r) (tree-empty? (cAr r))) (cDr r) r)))
240 (define (silent-output t u)
241 (when (and (tm-func? t 'document) (tm-func? u 'document))
242 (tree-insert! t (tree-arity t) (var-tree-children u))))
244 (define (silent-notify lan ses ch t)
245 ;;(display* "Silent notify " lan ", " ses ", " ch ", " t "\n")
246 (with l (pending-ref lan ses)
247 (with (in out err return opts) (silent-decode (car l))
248 (cond ((== ch "output")
249 (silent-output out t))
251 (silent-output err t))))))
253 (define (silent-cancel lan ses dead?)
254 ;;(display* "Silent cancel " lan ", " ses ", " dead? "\n")
255 (with l (pending-ref lan ses)
256 (with (in out err return opts) (silent-decode (car l))
257 (return (if dead? :dead :interrupted)))))
259 (tm-define (silent-feed lan ses in return opts)
260 (set! in (plugin-preprocess lan ses in opts))
261 (with ret (lambda (x)
262 (return (if (npair? x) x
263 (cons (plugin-postprocess lan ses (car x) opts)
264 (plugin-postprocess lan ses (cdr x) opts)))))
265 (with x (silent-encode in ret opts)
266 (apply plugin-feed `(,lan ,ses ,@(car x) ,(cdr x))))))
268 (tm-define (silent-feed* lan ses in return opts)
269 (with ret (lambda (x)
270 (return (cond ((== x :dead) '(script-dead))
271 ((== x :interrupted) '(script-interrupted))
272 ((!= (tm-arity (cdr x)) 0)
273 `(with "color" "red" ,(cdr x)))
275 (silent-feed lan ses in ret opts)))