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