(require 'cl-lib)
(defvar fsm-debug "*fsm-debug*"
"*Name of buffer for fsm debug messages.
If nil, don't output debug messages.")
(defvar fsm-debug-timestamp-format nil
"*Timestamp format (a string) for `fsm-debug-output'.
Default format is whatever `current-time-string' returns
followed by a colon and a space.")
(defun fsm-debug-output (format &rest args)
"Append debug output to buffer named by the variable `fsm-debug'.
FORMAT and ARGS are passed to `format'."
(when fsm-debug
(with-current-buffer (get-buffer-create fsm-debug)
(save-excursion
(goto-char (point-max))
(insert (if fsm-debug-timestamp-format
(format-time-string fsm-debug-timestamp-format)
(concat (current-time-string) ": "))
(apply 'format format args) "\n")))))
(cl-defmacro define-state-machine (name &key start sleep)
"Define a state machine class called NAME.
A function called start-NAME is created, which uses the argument
list and body specified in the :start argument. BODY should
return a list of the form (STATE STATE-DATA [TIMEOUT]), where
STATE is the initial state (defined by `define-state'),
STATE-DATA is any object, and TIMEOUT is the number of seconds
before a :timeout event will be sent to the state machine. BODY
may refer to the instance being created through the dynamically
bound variable `fsm'.
SLEEP-FUNCTION, if provided, takes one argument, the number of
seconds to sleep while allowing events concerning this state
machine to happen. There is probably no reason to change the
default, which is accept-process-output with rearranged
arguments.
\(fn NAME :start ((ARG ...) DOCSTRING BODY) [:sleep SLEEP-FUNCTION])"
(declare (debug (&define name :name start
&rest
&or [":start"
(lambda-list
[&optional ("interactive" interactive)]
stringp def-body)]
[":sleep" function-form])))
(let ((start-name (intern (format "start-%s" name)))
interactive-spec)
(cl-destructuring-bind (arglist docstring &body body) start
(when (and (consp (car body)) (eq 'interactive (caar body)))
(setq interactive-spec (list (pop body))))
(unless (stringp docstring)
(error "Docstring is not a string"))
`(progn
(put ',name :fsm-enter (make-hash-table :size 11 :test 'eq))
(put ',name :fsm-event (make-hash-table :size 11 :test 'eq))
(defun ,start-name ,arglist
,docstring
,@interactive-spec
(fsm-debug-output "Starting %s" ',name)
(let ((fsm (cl-gensym (concat "fsm-" ,(symbol-name name) "-"))))
(cl-destructuring-bind (state state-data &optional timeout)
(progn ,@body)
(put fsm :name ',name)
(put fsm :state nil)
(put fsm :state-data nil)
(put fsm :sleep ,(or sleep '(lambda (secs)
(accept-process-output
nil secs))))
(put fsm :deferred nil)
(fsm-update fsm state state-data timeout)
fsm)))))))
(cl-defmacro define-state (fsm-name state-name arglist &body body)
"Define a state called STATE-NAME in the state machine FSM-NAME.
ARGLIST and BODY make a function that gets called when the state
machine receives an event in this state. The arguments are:
FSM the state machine instance (treat it as opaque)
STATE-DATA An object
EVENT The occurred event, an object.
CALLBACK A function of one argument that expects the response
to this event, if any (often `ignore' is used)
If the event should return a response, the state machine should
arrange to call CALLBACK at some point in the future (not necessarily
in this handler).
The function should return a list of the form (NEW-STATE
NEW-STATE-DATA TIMEOUT):
NEW-STATE The next state, a symbol
NEW-STATE-DATA An object
TIMEOUT A number: send timeout event after this many seconds
nil: cancel existing timer
:keep: let existing timer continue
Alternatively, the function may return the keyword :defer, in
which case the event will be resent when the state machine enters
another state."
(declare (debug (&define name name :name handler lambda-list def-body)))
`(setf (gethash ',state-name (get ',fsm-name :fsm-event))
(lambda ,arglist ,@body)))
(cl-defmacro define-enter-state (fsm-name state-name arglist &body body)
"Define a function to call when FSM-NAME enters the state STATE-NAME.
ARGLIST and BODY make a function that gets called when the state
machine enters this state. The arguments are:
FSM the state machine instance (treat it as opaque)
STATE-DATA An object
The function should return a list of the form (NEW-STATE-DATA
TIMEOUT):
NEW-STATE-DATA An object
TIMEOUT A number: send timeout event after this many seconds
nil: cancel existing timer
:keep: let existing timer continue"
(declare (debug (&define name name :name enter lambda-list def-body)))
`(setf (gethash ',state-name (get ',fsm-name :fsm-enter))
(lambda ,arglist ,@body)))
(cl-defmacro define-fsm (name &key
start sleep states
(fsm-name 'fsm)
(state-data-name 'state-data)
(callback-name 'callback)
(event-name 'event))
"Define a state machine class called NAME, along with its STATES.
This macro is (further) syntatic sugar for `define-state-machine',
`define-state' and `define-enter-state' macros, q.v.
NAME is a symbol. Everything else is specified with a keyword arg.
START and SLEEP are the same as for `define-state-machine'.
STATES is a list, each element having the form (STATE-NAME . STATE-SPEC).
STATE-NAME is a symbol. STATE-SPEC is an alist with keys `:event' or
`:enter', and values a series of expressions representing the BODY of
a `define-state' or `define-enter-state' call, respectively.
FSM-NAME, STATE-DATA-NAME, CALLBACK-NAME, and EVENT-NAME are symbols,
used to construct the state functions' arglists."
`(progn
(define-state-machine ,name :start ,start :sleep ,sleep)
,@(cl-loop for (state-name . spec) in states
if (assq :enter spec) collect
`(define-enter-state ,name ,state-name
(,fsm-name ,state-data-name)
,@(cdr it))
end
if (assq :event spec) collect
`(define-state ,name ,state-name
(,fsm-name ,state-data-name
,event-name
,callback-name)
,@(cdr it))
end)))
(defun fsm-goodbye-cruel-world (name)
"Unbind functions related to fsm NAME (a symbol).
Includes start-NAME, and each fsm-NAME-STATE and fsm-NAME-enter-STATE.
Functions are `fmakunbound', which will probably give (fatal) pause to
any state machines using them. Return nil."
(interactive "SUnbind function definitions for fsm named: ")
(fmakunbound (intern (format "start-%s" name)))
(let (ht)
(when (hash-table-p (setq ht (get name :fsm-event)))
(clrhash ht)
(cl-remprop name :fsm-event))
(when (hash-table-p (setq ht (get name :fsm-enter)))
(clrhash ht)
(cl-remprop name :fsm-enter)))
nil)
(defun fsm-start-timer (fsm secs)
"Send a timeout event to FSM after SECS seconds.
The timer is canceled if another event occurs before, unless the
event handler explicitly asks to keep the timer."
(fsm-stop-timer fsm)
(put fsm
:timeout (run-with-timer
secs nil
#'fsm-send-sync fsm :timeout)))
(defun fsm-stop-timer (fsm)
"Stop the timeout timer of FSM."
(let ((timer (get fsm :timeout)))
(when (timerp timer)
(cancel-timer timer)
(put fsm :timeout nil))))
(defun fsm-maybe-change-timer (fsm timeout)
"Change the timer of FSM according to TIMEOUT."
(cond
((numberp timeout)
(fsm-start-timer fsm timeout))
((null timeout)
(fsm-stop-timer fsm))
))
(defun fsm-send (fsm event &optional callback)
"Send EVENT to FSM asynchronously.
If the state machine generates a response, eventually call
CALLBACK with the response as only argument."
(run-with-timer 0 nil #'fsm-send-sync fsm event callback))
(defun fsm-update (fsm new-state new-state-data timeout)
"Update FSM with NEW-STATE, NEW-STATE-DATA and TIMEOUT."
(let ((fsm-name (get fsm :name))
(old-state (get fsm :state)))
(put fsm :state new-state)
(put fsm :state-data new-state-data)
(fsm-maybe-change-timer fsm timeout)
(unless (eq old-state new-state)
(fsm-debug-output "%s enters %s" fsm-name new-state)
(let ((enter-fn (gethash new-state (get fsm-name :fsm-enter))))
(when (functionp enter-fn)
(fsm-debug-output "Found enter function for %s/%s" fsm-name new-state)
(condition-case e
(cl-destructuring-bind (newer-state-data newer-timeout)
(funcall enter-fn fsm new-state-data)
(put fsm :state-data newer-state-data)
(fsm-maybe-change-timer fsm newer-timeout))
((debug error)
(fsm-debug-output "%s/%s update didn't work: %S"
fsm-name new-state e)))))
(let ((deferred (nreverse (get fsm :deferred))))
(put fsm :deferred nil)
(dolist (event deferred)
(apply 'fsm-send-sync fsm event))))))
(defun fsm-send-sync (fsm event &optional callback)
"Send EVENT to FSM synchronously.
If the state machine generates a response, eventually call
CALLBACK with the response as only argument."
(save-match-data
(let* ((fsm-name (get fsm :name))
(state (get fsm :state))
(state-data (get fsm :state-data))
(state-fn (gethash state (get fsm-name :fsm-event))))
(fsm-debug-output "Sent %S to %s in state %s"
(or (car-safe event) event) fsm-name state)
(let ((result (condition-case e
(funcall state-fn fsm state-data event
(or callback 'ignore))
((debug error) (cons :error-signaled e)))))
(cond
((eq result :defer)
(let ((deferred (get fsm :deferred)))
(put fsm :deferred (cons (list event callback) deferred))))
((null result)
(fsm-debug-output "Warning: event %S ignored in state %s/%s"
event fsm-name state))
((eq (car-safe result) :error-signaled)
(fsm-debug-output "Error in %s/%s: %s"
fsm-name state
(error-message-string (cdr result))))
((and (listp result)
(<= 2 (length result))
(<= (length result) 3))
(cl-destructuring-bind (new-state new-state-data &optional timeout)
result
(fsm-update fsm new-state new-state-data timeout)))
(t
(fsm-debug-output "Incorrect return value in %s/%s: %S"
fsm-name state
result)))))))
(defun fsm-call (fsm event)
"Send EVENT to FSM synchronously, and wait for a reply.
Return the reply. `with-timeout' might be useful."
(let (reply)
(fsm-send-sync fsm event (lambda (r) (setq reply (list r))))
(while (null reply)
(fsm-sleep fsm 1))
(car reply)))
(defun fsm-make-filter (fsm)
"Return a filter function that sends events to FSM.
Events sent are of the form (:filter PROCESS STRING)."
(let ((fsm fsm))
(lambda (process string)
(fsm-send-sync fsm (list :filter process string)))))
(defun fsm-make-sentinel (fsm)
"Return a sentinel function that sends events to FSM.
Events sent are of the form (:sentinel PROCESS STRING)."
(let ((fsm fsm))
(lambda (process string)
(fsm-send-sync fsm (list :sentinel process string)))))
(defun fsm-sleep (fsm secs)
"Sleep up to SECS seconds in a way that lets FSM receive events."
(funcall (get fsm :sleep) secs))
(defun fsm-get-state-data (fsm)
"Return the state data of FSM.
Note the absence of a set function. The fsm should manage its
state data itself; other code should just send messages to it."
(get fsm :state-data))
(provide 'fsm)