1 ;;; fsm.el --- state machine library -*- lexical-binding: t; -*-
3 ;; Copyright (C) 2006, 2007, 2008 Magnus Henoch
5 ;; Author: Magnus Henoch <mange@freemail.hu>
6 ;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
8 ;; Package-Requires: ((emacs "24.1") (cl-lib "0.5"))
9 ;; Keywords: extensions
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)
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.
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.
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.
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
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.
47 ;; The essential macros/functions are:
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
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.
60 ;; Here is a simple (not using all the features of fsm.el) example:
62 ;; ;; -*- lexical-binding: t; -*-
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
79 ;; (:event (zow :pingg 0.1)))
81 ;; (:event (zow :pinggg 0.1)))
83 ;; (:event (zow :pong 1)))
85 ;; (:event (zow :ping (if (= 0 count)
86 ;; (fsm-goodbye-cruel-world 'pingpong)
88 ;; (fsm-send (start-pingpong -16) t)
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.
96 ;; -- Delete trailing whitespace.
98 ;; -- Use lexical binding.
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.
104 ;; NOTE: This is version 0.1ttn4 of fsm.el, with the following
105 ;; mods (an exercise in meta-meta-programming ;-) by ttn:
106 ;; -- Refill for easy (traditional 80-column) perusal.
107 ;; -- New var `fsm-debug-timestamp-format'.
108 ;; -- Make variables satisfy `user-variable-p'.
109 ;; -- Use `format' instead of `concat'.
110 ;; -- New func `fsm-goodbye-cruel-world'.
111 ;; -- Make start-function respect `interactive' spec.
112 ;; -- Make enter-/event-functions anonymous.
113 ;; -- New macro `define-fsm'.
114 ;; -- Example usage in Commentary.
118 ;; We require cl-lib at runtime, since we insert `cl-destructuring-bind' into
119 ;; modules that use fsm.el.
122 (defvar fsm-debug "*fsm-debug*"
123 "*Name of buffer for fsm debug messages.
124 If nil, don't output debug messages.")
126 (defvar fsm-debug-timestamp-format nil
127 "*Timestamp format (a string) for `fsm-debug-output'.
128 Default format is whatever `current-time-string' returns
129 followed by a colon and a space.")
131 (defun fsm-debug-output (format &rest args)
132 "Append debug output to buffer named by the variable `fsm-debug'.
133 FORMAT and ARGS are passed to `format'."
135 (with-current-buffer (get-buffer-create fsm-debug)
137 (goto-char (point-max))
138 (insert (if fsm-debug-timestamp-format
139 (format-time-string fsm-debug-timestamp-format)
140 (concat (current-time-string) ": "))
141 (apply 'format format args) "\n")))))
143 (cl-defmacro define-state-machine (name &key start sleep)
144 "Define a state machine class called NAME.
145 A function called start-NAME is created, which uses the argument
146 list and body specified in the :start argument. BODY should
147 return a list of the form (STATE STATE-DATA [TIMEOUT]), where
148 STATE is the initial state (defined by `define-state'),
149 STATE-DATA is any object, and TIMEOUT is the number of seconds
150 before a :timeout event will be sent to the state machine. BODY
151 may refer to the instance being created through the dynamically
152 bound variable `fsm'.
154 SLEEP-FUNCTION, if provided, takes one argument, the number of
155 seconds to sleep while allowing events concerning this state
156 machine to happen. There is probably no reason to change the
157 default, which is accept-process-output with rearranged
160 \(fn NAME :start ((ARG ...) DOCSTRING BODY) [:sleep SLEEP-FUNCTION])"
161 (declare (debug (&define name :name start
165 [&optional ("interactive" interactive)]
167 [":sleep" function-form])))
168 (let ((start-name (intern (format "start-%s" name)))
170 (cl-destructuring-bind (arglist docstring &body body) start
171 (when (and (consp (car body)) (eq 'interactive (caar body)))
172 (setq interactive-spec (list (pop body))))
173 (unless (stringp docstring)
174 (error "Docstring is not a string"))
176 (put ',name :fsm-enter (make-hash-table :size 11 :test 'eq))
177 (put ',name :fsm-event (make-hash-table :size 11 :test 'eq))
178 (defun ,start-name ,arglist
181 (fsm-debug-output "Starting %s" ',name)
182 (let ((fsm (list :fsm ',name)))
183 (cl-destructuring-bind (state state-data &optional timeout)
185 (nconc fsm (list :state nil :state-data nil
186 :sleep ,(or sleep (lambda (secs)
187 (accept-process-output
190 (fsm-update fsm state state-data timeout)
193 (cl-defmacro define-state (fsm-name state-name arglist &body body)
194 "Define a state called STATE-NAME in the state machine FSM-NAME.
195 ARGLIST and BODY make a function that gets called when the state
196 machine receives an event in this state. The arguments are:
198 FSM the state machine instance (treat it as opaque)
200 EVENT The occurred event, an object.
201 CALLBACK A function of one argument that expects the response
202 to this event, if any (often `ignore' is used)
204 If the event should return a response, the state machine should
205 arrange to call CALLBACK at some point in the future (not necessarily
208 The function should return a list of the form (NEW-STATE
209 NEW-STATE-DATA TIMEOUT):
211 NEW-STATE The next state, a symbol
212 NEW-STATE-DATA An object
213 TIMEOUT A number: send timeout event after this many seconds
214 nil: cancel existing timer
215 :keep: let existing timer continue
217 Alternatively, the function may return the keyword :defer, in
218 which case the event will be resent when the state machine enters
220 (declare (debug (&define name name :name handler lambda-list def-body)))
221 `(setf (gethash ',state-name (get ',fsm-name :fsm-event))
222 (lambda ,arglist ,@body)))
224 (cl-defmacro define-enter-state (fsm-name state-name arglist &body body)
225 "Define a function to call when FSM-NAME enters the state STATE-NAME.
226 ARGLIST and BODY make a function that gets called when the state
227 machine enters this state. The arguments are:
229 FSM the state machine instance (treat it as opaque)
232 The function should return a list of the form (NEW-STATE-DATA
235 NEW-STATE-DATA An object
236 TIMEOUT A number: send timeout event after this many seconds
237 nil: cancel existing timer
238 :keep: let existing timer continue"
239 (declare (debug (&define name name :name enter lambda-list def-body)))
240 `(setf (gethash ',state-name (get ',fsm-name :fsm-enter))
241 (lambda ,arglist ,@body)))
243 (cl-defmacro define-fsm (name &key
246 (state-data-name 'state-data)
247 (callback-name 'callback)
249 "Define a state machine class called NAME, along with its STATES.
250 This macro is (further) syntatic sugar for `define-state-machine',
251 `define-state' and `define-enter-state' macros, q.v.
253 NAME is a symbol. Everything else is specified with a keyword arg.
255 START and SLEEP are the same as for `define-state-machine'.
257 STATES is a list, each element having the form (STATE-NAME . STATE-SPEC).
258 STATE-NAME is a symbol. STATE-SPEC is an alist with keys `:event' or
259 `:enter', and values a series of expressions representing the BODY of
260 a `define-state' or `define-enter-state' call, respectively.
262 FSM-NAME, STATE-DATA-NAME, CALLBACK-NAME, and EVENT-NAME are symbols,
263 used to construct the state functions' arglists."
265 (define-state-machine ,name :start ,start :sleep ,sleep)
266 ,@(cl-loop for (state-name . spec) in states
267 if (assq :enter spec) collect
268 `(define-enter-state ,name ,state-name
269 (,fsm-name ,state-data-name)
272 if (assq :event spec) collect
273 `(define-state ,name ,state-name
274 (,fsm-name ,state-data-name
280 (defun fsm-goodbye-cruel-world (name)
281 "Unbind functions related to fsm NAME (a symbol).
282 Includes start-NAME, and each fsm-NAME-STATE and fsm-NAME-enter-STATE.
283 Functions are `fmakunbound', which will probably give (fatal) pause to
284 any state machines using them. Return nil."
285 (interactive "SUnbind function definitions for fsm named: ")
286 (fmakunbound (intern (format "start-%s" name)))
288 (when (hash-table-p (setq ht (get name :fsm-event)))
290 (cl-remprop name :fsm-event))
291 (when (hash-table-p (setq ht (get name :fsm-enter)))
293 (cl-remprop name :fsm-enter)))
296 (defun fsm-start-timer (fsm secs)
297 "Send a timeout event to FSM after SECS seconds.
298 The timer is canceled if another event occurs before, unless the
299 event handler explicitly asks to keep the timer."
304 :timeout (run-with-timer secs
309 (defun fsm-stop-timer (fsm)
310 "Stop the timeout timer of FSM."
311 (let ((timer (plist-get (cddr fsm) :timeout)))
314 (setf (cddr fsm) (plist-put (cddr fsm) :timeout nil)))))
316 (defun fsm-maybe-change-timer (fsm timeout)
317 "Change the timer of FSM according to TIMEOUT."
320 (fsm-start-timer fsm timeout))
322 (fsm-stop-timer fsm))
323 ;; :keep needs no timer change
326 (defun fsm-send (fsm event &optional callback)
327 "Send FSM EVENT asynchronously.
328 If the state machine generates a response, eventually call
329 CALLBACK with the response as only argument."
330 (run-with-timer 0 nil #'fsm-send-sync fsm event callback))
332 (defun fsm-update (fsm new-state new-state-data timeout)
333 "Update FSM with NEW-STATE, NEW-STATE-DATA and TIMEOUT."
334 (let ((fsm-name (cadr fsm))
335 (old-state (plist-get (cddr fsm) :state)))
336 (plist-put (cddr fsm) :state new-state)
337 (plist-put (cddr fsm) :state-data new-state-data)
338 (fsm-maybe-change-timer fsm timeout)
340 ;; On state change, call enter function and send deferred events
342 (unless (eq old-state new-state)
343 (fsm-debug-output "%s enters %s" fsm-name new-state)
344 (let ((enter-fn (gethash new-state (get fsm-name :fsm-enter))))
345 (when (functionp enter-fn)
346 (fsm-debug-output "Found enter function for %s/%s" fsm-name new-state)
348 (cl-destructuring-bind (newer-state-data newer-timeout)
349 (funcall enter-fn fsm new-state-data)
350 (plist-put (cddr fsm) :state-data newer-state-data)
351 (fsm-maybe-change-timer fsm newer-timeout))
353 (fsm-debug-output "%s/%s update didn't work: %S"
354 fsm-name new-state e)))))
356 (let ((deferred (nreverse (plist-get (cddr fsm) :deferred))))
358 (plist-put (cddr fsm) :deferred nil))
359 (dolist (event deferred)
360 (apply 'fsm-send-sync fsm event))))))
362 (defun fsm-send-sync (fsm event &optional callback)
363 "Send FSM EVENT synchronously.
364 If the state machine generates a response, eventually call
365 CALLBACK with the response as only argument."
367 (let* ((fsm-name (cl-second fsm))
368 (state (plist-get (cddr fsm) :state))
369 (state-data (plist-get (cddr 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.
382 (let ((deferred (plist-get (cddr fsm) :deferred)))
383 (plist-put (cddr fsm) :deferred
384 (cons (list event callback) deferred))))
386 (fsm-debug-output "Warning: event %S ignored in state %s/%s"
387 event fsm-name state))
388 ((eq (car-safe result) :error-signaled)
389 (fsm-debug-output "Error in %s/%s: %s"
391 (error-message-string (cdr result))))
393 (<= 2 (length result))
394 (<= (length result) 3))
395 (cl-destructuring-bind (new-state new-state-data &optional timeout)
397 (fsm-update fsm new-state new-state-data timeout)))
399 (fsm-debug-output "Incorrect return value in %s/%s: %S"
403 (defun fsm-call (fsm event)
404 "Send FSM EVENT synchronously, and wait for a reply.
405 Return the reply. `with-timeout' might be useful."
407 (fsm-send-sync fsm event (lambda (r) (setq reply (list r))))
412 (defun fsm-make-filter (fsm)
413 "Return a filter function that sends events to FSM.
414 Events sent are of the form (:filter PROCESS STRING)."
416 (lambda (process string)
417 (fsm-send-sync fsm (list :filter process string)))))
419 (defun fsm-make-sentinel (fsm)
420 "Return a sentinel function that sends events to FSM.
421 Events sent are of the form (:sentinel PROCESS STRING)."
423 (lambda (process string)
424 (fsm-send-sync fsm (list :sentinel process string)))))
426 (defun fsm-sleep (fsm secs)
427 "Let FSM receive events while sleeping up to SECS seconds."
428 (funcall (plist-get (cddr fsm) :sleep) secs))
430 (defun fsm-get-state-data (fsm)
431 "Return the state data of FSM.
432 Note the absence of a set function. The fsm should manage its
433 state data itself; other code should just send messages to it."
434 (plist-get (cddr fsm) :state-data))