]> code.delx.au - gnu-emacs-elpa/blob - packages/fsm/fsm.el
fsm: Use lexical binding
[gnu-emacs-elpa] / packages / fsm / fsm.el
1 ;;; fsm.el --- state machine library -*- lexical-binding: t; -*-
2
3 ;; Copyright (C) 2006, 2007, 2008 Magnus Henoch
4
5 ;; Author: Magnus Henoch <mange@freemail.hu>
6 ;; Version: 0.1ttn4
7
8 ;; This file is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 2, or (at your option)
11 ;; any later version.
12
13 ;; This file is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details.
17
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with GNU Emacs; see the file COPYING. If not, write to
20 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 ;; Boston, MA 02110-1301, USA.
22
23 ;;; Commentary:
24
25 ;; fsm.el is an exercise in metaprogramming inspired by gen_fsm of
26 ;; Erlang/OTP. It aims to make asynchronous programming in Emacs Lisp
27 ;; easy and fun. By "asynchronous" I mean that long-lasting tasks
28 ;; don't interfer with normal editing.
29
30 ;; Some people say that it would be nice if Emacs Lisp had threads
31 ;; and/or continuations. They are probably right, but there are few
32 ;; things that can't be made to run in the background using facilities
33 ;; already available: timers, filters and sentinels. As the code can
34 ;; become a bit messy when using such means, with callbacks everywhere
35 ;; and such things, it can be useful to structure the program as a
36 ;; state machine.
37
38 ;; In this model, a state machine passes between different "states",
39 ;; which are actually only different event handler functions. The
40 ;; state machine receives "events" (from timers, filters, user
41 ;; requests, etc) and reacts to them, possibly entering another state,
42 ;; possibly returning a value.
43
44 ;; The essential macros/functions are:
45 ;;
46 ;; define-state-machine - create start-FOO function
47 ;; define-state - event handler for each state (required)
48 ;; define-enter-state - called when entering a state (optional)
49 ;; define-fsm - encapsulates the above three (more sugar!)
50 ;; fsm-send - send an event to a state machine
51 ;; fsm-call - send an event and wait for reply
52
53 ;; fsm.el is similar to but different from Distel:
54 ;; <URL:http://fresh.homeunix.net/~luke/distel/>
55 ;; Emacs' tq library is a similar idea.
56
57 ;; Here is a simple (not using all the features of fsm.el) example:
58 ;;
59 ;; ;; -*- lexical-binding: t; -*-
60 ;; (require 'cl)
61 ;; (labels ((hey (n ev)
62 ;; (message "%d (%s)\tp%sn%s!" n ev
63 ;; (if (zerop (% n 4)) "o" "i")
64 ;; (make-string (max 1 (abs n)) ?g))))
65 ;; (macrolet ((zow (next timeout)
66 ;; `(progn (hey (incf count) event)
67 ;; (list ,next count ,timeout))))
68 ;; (define-fsm pingpong
69 ;; :start ((init) "Start a pingpong fsm."
70 ;; (interactive "nInit (number, negative to auto-terminate): ")
71 ;; (list :ping (ash (ash init -2) 2) ; 4 is death
72 ;; (when (interactive-p) 0)))
73 ;; :state-data-name count
74 ;; :states
75 ;; ((:ping
76 ;; (:event (zow :pingg 0.1)))
77 ;; (:pingg
78 ;; (:event (zow :pinggg 0.1)))
79 ;; (:pinggg
80 ;; (:event (zow :pong 1)))
81 ;; (:pong
82 ;; (:event (zow :ping (if (= 0 count)
83 ;; (fsm-goodbye-cruel-world 'pingpong)
84 ;; 3))))))))
85 ;; (fsm-send (start-pingpong -16) t)
86 ;;
87 ;; Copy into a buffer, uncomment, and type M-x eval-buffer RET.
88 ;; Alternatively, you can replace the `fsm-goodbye-cruel-world'
89 ;; form with `nil', eval just the `labels' form and then type
90 ;; M-x start-pingpong RET -16 RET.
91
92 ;; Version 0.2:
93 ;; -- Delete trailing whitespace.
94 ;; -- Fix formatting.
95 ;; -- Use lexical binding.
96
97 ;; NOTE: This is version 0.1ttn4 of fsm.el, with the following
98 ;; mods (an exercise in meta-meta-programming ;-) by ttn:
99 ;; -- Refill for easy (traditional 80-column) perusal.
100 ;; -- New var `fsm-debug-timestamp-format'.
101 ;; -- Make variables satisfy `user-variable-p'.
102 ;; -- Use `format' instead of `concat'.
103 ;; -- New func `fsm-goodbye-cruel-world'.
104 ;; -- Make start-function respect `interactive' spec.
105 ;; -- Make enter-/event-functions anonymous.
106 ;; -- New macro `define-fsm'.
107 ;; -- Example usage in Commentary.
108
109 ;;; Code:
110
111 ;; We require cl at runtime, since we insert `destructuring-bind' into
112 ;; modules that use fsm.el.
113 (require 'cl)
114
115 (defvar fsm-debug "*fsm-debug*"
116 "*Name of buffer for fsm debug messages.
117 If nil, don't output debug messages.")
118
119 (defvar fsm-debug-timestamp-format nil
120 "*Timestamp format (a string) for `fsm-debug-output'.
121 Default format is whatever `current-time-string' returns
122 followed by a colon and a space.")
123
124 (defun fsm-debug-output (format &rest args)
125 "Append debug output to buffer named by the variable `fsm-debug'.
126 FORMAT and ARGS are passed to `format'."
127 (when fsm-debug
128 (with-current-buffer (get-buffer-create fsm-debug)
129 (save-excursion
130 (goto-char (point-max))
131 (insert (if fsm-debug-timestamp-format
132 (format-time-string fsm-debug-timestamp-format)
133 (concat (current-time-string) ": "))
134 (apply 'format format args) "\n")))))
135
136 (defmacro* define-state-machine (name &key start sleep)
137 "Define a state machine class called NAME.
138 A function called start-NAME is created, which uses the argument
139 list and body specified in the :start argument. BODY should
140 return a list of the form (STATE STATE-DATA [TIMEOUT]), where
141 STATE is the initial state (defined by `define-state'),
142 STATE-DATA is any object, and TIMEOUT is the number of seconds
143 before a :timeout event will be sent to the state machine. BODY
144 may refer to the instance being created through the dynamically
145 bound variable `fsm'.
146
147 SLEEP-FUNCTION, if provided, takes one argument, the number of
148 seconds to sleep while allowing events concerning this state
149 machine to happen. There is probably no reason to change the
150 default, which is accept-process-output with rearranged
151 arguments.
152
153 \(fn NAME :start ((ARG ...) DOCSTRING BODY) [:sleep SLEEP-FUNCTION])"
154 (declare (debug (&define name :name start
155 &rest
156 &or [":start"
157 (lambda-list
158 [&optional ("interactive" interactive)]
159 stringp def-body)]
160 [":sleep" function-form])))
161 (let ((start-name (intern (format "start-%s" name)))
162 interactive-spec)
163 (destructuring-bind (arglist docstring &body body) start
164 (when (and (consp (car body)) (eq 'interactive (caar body)))
165 (setq interactive-spec (list (pop body))))
166 (unless (stringp docstring)
167 (error "Docstring is not a string"))
168 `(progn
169 (put ',name :fsm-enter (make-hash-table :size 11 :test 'eq))
170 (put ',name :fsm-event (make-hash-table :size 11 :test 'eq))
171 (defun ,start-name ,arglist
172 ,docstring
173 ,@interactive-spec
174 (fsm-debug-output "Starting %s" ',name)
175 (let ((fsm (list :fsm ',name)))
176 (destructuring-bind (state state-data &optional timeout)
177 (progn ,@body)
178 (nconc fsm (list :state nil :state-data nil
179 :sleep ,(or sleep (lambda (secs)
180 (accept-process-output
181 nil secs)))
182 :deferred nil))
183 (fsm-update fsm state state-data timeout)
184 fsm)))))))
185
186 (defmacro* define-state (fsm-name state-name arglist &body body)
187 "Define a state called STATE-NAME in the state machine FSM-NAME.
188 ARGLIST and BODY make a function that gets called when the state
189 machine receives an event in this state. The arguments are:
190
191 FSM the state machine instance (treat it as opaque)
192 STATE-DATA An object
193 EVENT The occurred event, an object.
194 CALLBACK A function of one argument that expects the response
195 to this event, if any (often `ignore' is used)
196
197 If the event should return a response, the state machine should
198 arrange to call CALLBACK at some point in the future (not necessarily
199 in this handler).
200
201 The function should return a list of the form (NEW-STATE
202 NEW-STATE-DATA TIMEOUT):
203
204 NEW-STATE The next state, a symbol
205 NEW-STATE-DATA An object
206 TIMEOUT A number: send timeout event after this many seconds
207 nil: cancel existing timer
208 :keep: let existing timer continue
209
210 Alternatively, the function may return the keyword :defer, in
211 which case the event will be resent when the state machine enters
212 another state."
213 (declare (debug (&define name name :name handler lambda-list def-body)))
214 `(setf (gethash ',state-name (get ',fsm-name :fsm-event))
215 (lambda ,arglist ,@body)))
216
217 (defmacro* define-enter-state (fsm-name state-name arglist &body body)
218 "Define a function to call when FSM-NAME enters the state STATE-NAME.
219 ARGLIST and BODY make a function that gets called when the state
220 machine enters this state. The arguments are:
221
222 FSM the state machine instance (treat it as opaque)
223 STATE-DATA An object
224
225 The function should return a list of the form (NEW-STATE-DATA
226 TIMEOUT):
227
228 NEW-STATE-DATA An object
229 TIMEOUT A number: send timeout event after this many seconds
230 nil: cancel existing timer
231 :keep: let existing timer continue"
232 (declare (debug (&define name name :name enter lambda-list def-body)))
233 `(setf (gethash ',state-name (get ',fsm-name :fsm-enter))
234 (lambda ,arglist ,@body)))
235
236 (defmacro* define-fsm (name &key
237 start sleep states
238 (fsm-name 'fsm)
239 (state-data-name 'state-data)
240 (callback-name 'callback)
241 (event-name 'event))
242 "Define a state machine class called NAME, along with its STATES.
243 This macro is (further) syntatic sugar for `define-state-machine',
244 `define-state' and `define-enter-state' macros, q.v.
245
246 NAME is a symbol. Everything else is specified with a keyword arg.
247
248 START and SLEEP are the same as for `define-state-machine'.
249
250 STATES is a list, each element having the form (STATE-NAME . STATE-SPEC).
251 STATE-NAME is a symbol. STATE-SPEC is an alist with keys `:event' or
252 `:enter', and values a series of expressions representing the BODY of
253 a `define-state' or `define-enter-state' call, respectively.
254
255 FSM-NAME, STATE-DATA-NAME, CALLBACK-NAME, and EVENT-NAME are symbols,
256 used to construct the state functions' arglists."
257 `(progn
258 (define-state-machine ,name :start ,start :sleep ,sleep)
259 ,@(loop for (state-name . spec) in states
260 if (assq :enter spec) collect
261 `(define-enter-state ,name ,state-name
262 (,fsm-name ,state-data-name)
263 ,@(cdr it))
264 end
265 if (assq :event spec) collect
266 `(define-state ,name ,state-name
267 (,fsm-name ,state-data-name
268 ,event-name
269 ,callback-name)
270 ,@(cdr it))
271 end)))
272
273 (defun fsm-goodbye-cruel-world (name)
274 "Unbind functions related to fsm NAME (a symbol).
275 Includes start-NAME, and each fsm-NAME-STATE and fsm-NAME-enter-STATE.
276 Functions are `fmakunbound', which will probably give (fatal) pause to
277 any state machines using them. Return nil."
278 (interactive "SUnbind function definitions for fsm named: ")
279 (fmakunbound (intern (format "start-%s" name)))
280 (let (ht)
281 (when (hash-table-p (setq ht (get name :fsm-event)))
282 (clrhash ht)
283 (remprop name :fsm-event))
284 (when (hash-table-p (setq ht (get name :fsm-enter)))
285 (clrhash ht)
286 (remprop name :fsm-enter)))
287 nil)
288
289 (defun fsm-start-timer (fsm secs)
290 "Send a timeout event to FSM after SECS seconds.
291 The timer is canceled if another event occurs before, unless the
292 event handler explicitly asks to keep the timer."
293 (fsm-stop-timer fsm)
294 (setf (cddr fsm)
295 (plist-put
296 (cddr fsm)
297 :timeout (run-with-timer secs
298 nil
299 #'fsm-send-sync fsm
300 :timeout))))
301
302 (defun fsm-stop-timer (fsm)
303 "Stop the timeout timer of FSM."
304 (let ((timer (plist-get (cddr fsm) :timeout)))
305 (when (timerp timer)
306 (cancel-timer timer)
307 (setf (cddr fsm) (plist-put (cddr fsm) :timeout nil)))))
308
309 (defun fsm-maybe-change-timer (fsm timeout)
310 "Change the timer of FSM according to TIMEOUT."
311 (cond
312 ((numberp timeout)
313 (fsm-start-timer fsm timeout))
314 ((null timeout)
315 (fsm-stop-timer fsm))
316 ;; :keep needs no timer change
317 ))
318
319 (defun fsm-send (fsm event &optional callback)
320 "Send EVENT to FSM asynchronously.
321 If the state machine generates a response, eventually call
322 CALLBACK with the response as only argument."
323 (run-with-timer 0 nil #'fsm-send-sync fsm event callback))
324
325 (defun fsm-update (fsm new-state new-state-data timeout)
326 (let ((fsm-name (cadr fsm))
327 (old-state (plist-get (cddr fsm) :state)))
328 (plist-put (cddr fsm) :state new-state)
329 (plist-put (cddr fsm) :state-data new-state-data)
330 (fsm-maybe-change-timer fsm timeout)
331
332 ;; On state change, call enter function and send deferred events
333 ;; again.
334 (unless (eq old-state new-state)
335 (fsm-debug-output "%s enters %s" fsm-name new-state)
336 (let ((enter-fn (gethash new-state (get fsm-name :fsm-enter))))
337 (when (functionp enter-fn)
338 (fsm-debug-output "Found enter function for %S" new-state)
339 (condition-case e
340 (destructuring-bind (newer-state-data newer-timeout)
341 (funcall enter-fn fsm new-state-data)
342 (fsm-debug-output "Using data from enter function")
343 (plist-put (cddr fsm) :state-data newer-state-data)
344 (fsm-maybe-change-timer fsm newer-timeout))
345 ((debug error)
346 (fsm-debug-output "Didn't work: %S" e)))))
347
348 (let ((deferred (nreverse (plist-get (cddr fsm) :deferred))))
349 (setf (cddr fsm)
350 (plist-put (cddr fsm) :deferred nil))
351 (dolist (event deferred)
352 (apply 'fsm-send-sync fsm event))))))
353
354 (defun fsm-send-sync (fsm event &optional callback)
355 "Send EVENT to FSM synchronously.
356 If the state machine generates a response, eventually call
357 CALLBACK with the response as only argument."
358 (save-match-data
359 (let* ((fsm-name (second fsm))
360 (state (plist-get (cddr fsm) :state))
361 (state-data (plist-get (cddr fsm) :state-data))
362 (state-fn (gethash state (get fsm-name :fsm-event))))
363 ;; If the event is a list, output only the car, to avoid an
364 ;; overflowing debug buffer.
365 (fsm-debug-output "Sent %S to %s in state %s"
366 (or (car-safe event) event) fsm-name state)
367 (let ((result (condition-case e
368 (funcall state-fn fsm state-data event
369 (or callback 'ignore))
370 ((debug error) (cons :error-signaled e)))))
371 ;; Special case for deferring an event until next state change.
372 (cond
373 ((eq result :defer)
374 (let ((deferred (plist-get (cddr fsm) :deferred)))
375 (plist-put (cddr fsm) :deferred
376 (cons (list event callback) deferred))))
377 ((null result)
378 (fsm-debug-output "Warning: event %S ignored in state %s/%s"
379 event fsm-name state))
380 ((eq (car-safe result) :error-signaled)
381 (fsm-debug-output "Error in %s/%s: %s"
382 fsm-name state
383 (error-message-string (cdr result))))
384 ((and (listp result)
385 (<= 2 (length result))
386 (<= (length result) 3))
387 (destructuring-bind (new-state new-state-data &optional timeout)
388 result
389 (fsm-update fsm new-state new-state-data timeout)))
390 (t
391 (fsm-debug-output "Incorrect return value in %s/%s: %S"
392 fsm-name state
393 result)))))))
394
395 (defun fsm-call (fsm event)
396 "Send EVENT to FSM synchronously, and wait for a reply.
397 Return the reply.
398 `with-timeout' might be useful."
399 (let (reply)
400 (fsm-send-sync fsm event (lambda (r) (setq reply (list r))))
401 (while (null reply)
402 (fsm-sleep fsm 1))
403 (car reply)))
404
405 (defun fsm-make-filter (fsm)
406 "Return a filter function that sends events to FSM.
407 Events sent are of the form (:filter PROCESS STRING)."
408 (let ((fsm fsm))
409 (lambda (process string)
410 (fsm-send-sync fsm (list :filter process string)))))
411
412 (defun fsm-make-sentinel (fsm)
413 "Return a sentinel function that sends events to FSM.
414 Events sent are of the form (:sentinel PROCESS STRING)."
415 (let ((fsm fsm))
416 (lambda (process string)
417 (fsm-send-sync fsm (list :sentinel process string)))))
418
419 (defun fsm-sleep (fsm secs)
420 "Sleep up to SECS seconds in a way that lets FSM receive events."
421 (funcall (plist-get (cddr fsm) :sleep) secs))
422
423 (defun fsm-get-state-data (fsm)
424 "Return the state data of FSM.
425 Note the absence of a set function. The fsm should manage its
426 state data itself; other code should just send messages to it."
427 (plist-get (cddr fsm) :state-data))
428
429 (provide 'fsm)
430
431 ;;; fsm.el ends here