fsm.el

   1 ;;; fsm.el --- state machine library
   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 ;; (require 'cl)
  60 ;; (labels ((hey (n ev)
  61 ;;               (message "%d (%s)\tp%sn%s!" n ev
  62 ;;                        (if (zerop (% n 4)) "o" "i")
  63 ;;                        (make-string (max 1 (abs n)) ?g))))
  64 ;;   (macrolet ((zow (next timeout)
  65 ;;                   `(progn (hey (incf count) event)
  66 ;;                           (list ,next count ,timeout))))
  67 ;;     (define-fsm pingpong
  68 ;;       :start ((init) "Start a pingpong fsm."
  69 ;;               (interactive "nInit (number, negative to auto-terminate): ")
  70 ;;               (list :ping (ash (ash init -2) 2) ; 4 is death
  71 ;;                     (when (interactive-p) 0)))
  72 ;;       :state-data-name count
  73 ;;       :states
  74 ;;       ((:ping
  75 ;;         (:event (zow :pingg 0.1)))
  76 ;;        (:pingg
  77 ;;         (:event (zow :pinggg 0.1)))
  78 ;;        (:pinggg
  79 ;;         (:event (zow :pong 1)))
  80 ;;        (:pong
  81 ;;         (:event (zow :ping (if (= 0 count)
  82 ;;                                (fsm-goodbye-cruel-world 'pingpong)
  83 ;;                              3))))))))
  84 ;;
  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 ;; NOTE: This is version 0.1ttn4 of fsm.el, with the following
  93 ;; mods (an exercise in meta-meta-programming ;-) by ttn:
  94 ;; -- Refill for easy (traditional 80-column) perusal.
  95 ;; -- New var `fsm-debug-timestamp-format'.
  96 ;; -- Make variables satisfy `user-variable-p'.
  97 ;; -- Use `format' instead of `concat'.
  98 ;; -- New func `fsm-goodbye-cruel-world'.
  99 ;; -- Make start-function respect `interactive' spec.
 100 ;; -- Make enter-/event-functions anonymous.
 101 ;; -- New macro `define-fsm'.
 102 ;; -- Example usage in Commentary.
 103
 104 ;;; Code:
 105
 106 (eval-when-compile (require 'cl))
 107
 108 (defvar fsm-debug "*fsm-debug*"
 109   "*Name of buffer for fsm debug messages.
 110 If nil, don't output debug messages.")
 111
 112 (defvar fsm-debug-timestamp-format nil
 113   "*Timestamp format (a string) for `fsm-debug-output'.
 114 Default format is whatever `current-time-string' returns
 115 followed by a colon and a space.")
 116
 117 (defun fsm-debug-output (format &rest args)
 118   "Append debug output to buffer named by `fsm-debug'.
 119 FORMAT and ARGS are passed to `format'."
 120   (when fsm-debug
 121     (with-current-buffer (get-buffer-create fsm-debug)
 122       (save-excursion
 123         (goto-char (point-max))
 124         (insert (if fsm-debug-timestamp-format
 125                     (format-time-string fsm-debug-timestamp-format)
 126                   (concat (current-time-string) ": "))
 127                 (apply 'format format args) "\n")))))
 128
 129 (defmacro* define-state-machine (name &key start sleep)
 130   "Define a state machine class called NAME.
 131 A function called start-NAME is created, which uses the argument
 132 list and body specified in the :start argument.  BODY should
 133 return a list of the form (STATE STATE-DATA [TIMEOUT]), where
 134 STATE is the initial state (defined by `define-state'),
 135 STATE-DATA is any object, and TIMEOUT is the number of seconds
 136 before a :timeout event will be sent to the state machine.  BODY
 137 may refer to the instance being created through the dynamically
 138 bound variable `fsm'.
 139
 140 SLEEP-FUNCTION, if provided, takes one argument, the number of
 141 seconds to sleep while allowing events concerning this state
 142 machine to happen.  There is probably no reason to change the
 143 default, which is accept-process-output with rearranged
 144 arguments.
 145
 146 \(fn NAME :start ((ARG ...) DOCSTRING BODY) [:sleep SLEEP-FUNCTION])"
 147   (declare (debug (&define name :name start
 148                            &rest
 149                            &or [":start"
 150                                 (lambda-list
 151                                  [&optional ("interactive" interactive)]
 152                                  stringp def-body)]
 153                            [":sleep" function-form])))
 154   (let ((start-name (intern (format "start-%s" name)))
 155         interactive-spec)
 156     (destructuring-bind (arglist docstring &body body) start
 157       (when (and (consp (car body)) (eq 'interactive (caar body)))
 158           (setq interactive-spec (list (pop body))))
 159       (unless (stringp docstring)
 160         (error "Docstring is not a string"))
 161       `(progn
 162          (put ',name :fsm-enter (make-hash-table :size 11 :test 'eq))
 163          (put ',name :fsm-event (make-hash-table :size 11 :test 'eq))
 164          (defun ,start-name ,arglist
 165            ,docstring
 166            ,@interactive-spec
 167            (fsm-debug-output "Starting %s" ',name)
 168            (let ((fsm (list :fsm ',name)))
 169              (destructuring-bind (state state-data &optional timeout)
 170                  (progn ,@body)
 171                (nconc fsm (list :state nil :state-data nil
 172                                 :sleep ,(or sleep (lambda (secs)
 173                                                     (accept-process-output
 174                                                      nil secs)))
 175                                 :deferred nil))
 176                (fsm-update fsm state state-data timeout)
 177                fsm)))))))
 178
 179 (defmacro* define-state (fsm-name state-name arglist &body body)
 180   "Define a state called STATE-NAME in the state machine FSM-NAME.
 181 ARGLIST and BODY make a function that gets called when the state
 182 machine receives an event in this state.  The arguments are:
 183
 184 FSM         the state machine instance (treat it as opaque)
 185 STATE-DATA  An object
 186 EVENT       The occurred event, an object.
 187 CALLBACK    A function of one argument that expects the response
 188             to this event, if any (often `ignore' is used)
 189
 190 If the event should return a response, the state machine should
 191 arrange to call CALLBACK at some point in the future (not necessarily
 192 in this handler).
 193
 194 The function should return a list of the form (NEW-STATE
 195 NEW-STATE-DATA TIMEOUT):
 196
 197 NEW-STATE      The next state, a symbol
 198 NEW-STATE-DATA An object
 199 TIMEOUT        A number: send timeout event after this many seconds
 200                nil: cancel existing timer
 201                :keep: let existing timer continue
 202
 203 Alternatively, the function may return the keyword :defer, in
 204 which case the event will be resent when the state machine enters
 205 another state."
 206   (declare (debug (&define name name :name handler lambda-list def-body)))
 207   `(setf (gethash ',state-name (get ',fsm-name :fsm-event))
 208          (lambda ,arglist ,@body)))
 209
 210 (defmacro* define-enter-state (fsm-name state-name arglist &body body)
 211   "Define a function to call when FSM-NAME enters the state STATE-NAME.
 212 ARGLIST and BODY make a function that gets called when the state
 213 machine enters this state.  The arguments are:
 214
 215 FSM         the state machine instance (treat it as opaque)
 216 STATE-DATA  An object
 217
 218 The function should return a list of the form (NEW-STATE-DATA
 219 TIMEOUT):
 220
 221 NEW-STATE-DATA An object
 222 TIMEOUT        A number: send timeout event after this many seconds
 223                nil: cancel existing timer
 224                :keep: let existing timer continue"
 225   (declare (debug (&define name name :name enter lambda-list def-body)))
 226   `(setf (gethash ',state-name (get ',fsm-name :fsm-enter))
 227          (lambda ,arglist ,@body)))
 228
 229 (defmacro* define-fsm (name &key
 230                             start sleep states
 231                             (fsm-name 'fsm)
 232                             (state-data-name 'state-data)
 233                             (callback-name 'callback)
 234                             (event-name 'event))
 235   "Define a state machine class called NAME, along with its STATES.
 236 This macro is (further) syntatic sugar for `define-state-machine',
 237 `define-state' and `define-enter-state' macros, q.v.
 238
 239 NAME is a symbol.  Everything else is specified with a keyword arg.
 240
 241 START and SLEEP are the same as for `define-state-machine'.
 242
 243 STATES is a list, each element having the form (STATE-NAME . STATE-SPEC).
 244 STATE-NAME is a symbol.  STATE-SPEC is an alist with keys `:event' or
 245 `:enter', and values a series of expressions representing the BODY of
 246 a `define-state' or `define-enter-state' call, respectively.
 247
 248 FSM-NAME, STATE-DATA-NAME, CALLBACK-NAME, and EVENT-NAME are symbols,
 249 used to construct the state functions' arglists."
 250   `(progn
 251      (define-state-machine ,name :start ,start :sleep ,sleep)
 252      ,@(loop for (state-name . spec) in states
 253              if (assq :enter spec) collect
 254              `(define-enter-state ,name ,state-name
 255                 (,fsm-name ,state-data-name)
 256                 ,@(cdr it))
 257              end
 258              if (assq :event spec) collect
 259              `(define-state ,name ,state-name
 260                 (,fsm-name ,state-data-name
 261                            ,event-name
 262                            ,callback-name)
 263                 ,@(cdr it))
 264              end)))
 265
 266 (defun fsm-goodbye-cruel-world (name)
 267   "Unbind functions related to fsm NAME (a symbol).
 268 Includes start-NAME, and each fsm-NAME-STATE and fsm-NAME-enter-STATE.
 269 Functions are `fmakunbound', which will probably give (fatal) pause to
 270 any state machines using them.  Return nil."
 271   (interactive "SUnbind function definitions for fsm named: ")
 272   (fmakunbound (intern (format "start-%s" name)))
 273   (let (ht)
 274     (when (hash-table-p (setq ht (get name :fsm-event)))
 275       (clrhash ht)
 276       (remprop name :fsm-event))
 277     (when (hash-table-p (setq ht (get name :fsm-enter)))
 278       (clrhash ht)
 279       (remprop name :fsm-enter)))
 280   nil)
 281
 282 (defun fsm-start-timer (fsm secs)
 283   "Send a timeout event to FSM after SECS seconds.
 284 The timer is canceled if another event occurs before, unless the
 285 event handler explicitly asks to keep the timer."
 286   (fsm-stop-timer fsm)
 287   (setf (cddr fsm)
 288         (plist-put
 289          (cddr fsm)
 290          :timeout (run-with-timer secs
 291                                   nil
 292                                   #'fsm-send-sync fsm
 293                                   :timeout))))
 294
 295 (defun fsm-stop-timer (fsm)
 296   "Stop the timeout timer of FSM."
 297   (let ((timer (plist-get (cddr fsm) :timeout)))
 298     (when (timerp timer)
 299       (cancel-timer timer)
 300       (setf (cddr fsm) (plist-put (cddr fsm) :timeout nil)))))
 301
 302 (defun fsm-maybe-change-timer (fsm timeout)
 303   "Change the timer of FSM according to TIMEOUT."
 304   (cond
 305    ((numberp timeout)
 306     (fsm-start-timer fsm timeout))
 307    ((null timeout)
 308     (fsm-stop-timer fsm))
 309    ;; :keep needs no timer change
 310    ))
 311
 312 (defun fsm-send (fsm event &optional callback)
 313   "Send EVENT to FSM asynchronously.
 314 If the state machine generates a response, eventually call
 315 CALLBACK with the response as only argument."
 316   (run-with-timer 0 nil #'fsm-send-sync fsm event callback))
 317
 318 (defun fsm-update (fsm new-state new-state-data timeout)
 319   (let ((fsm-name (cadr fsm))
 320         (old-state (plist-get (cddr fsm) :state)))
 321     (plist-put (cddr fsm) :state new-state)
 322     (plist-put (cddr fsm) :state-data new-state-data)
 323     (fsm-maybe-change-timer fsm timeout)
 324
 325     ;; On state change, call enter function and send deferred events
 326     ;; again.
 327     (unless (eq old-state new-state)
 328       (fsm-debug-output "%s enters %s" fsm-name new-state)
 329       (let ((enter-fn (gethash new-state (get fsm-name :fsm-enter))))
 330         (when (functionp enter-fn)
 331           (fsm-debug-output "Found enter function for %S: %S" new-state enter-fn)
 332           (condition-case e
 333               (destructuring-bind (newer-state-data newer-timeout)
 334                   (funcall enter-fn fsm new-state-data)
 335                 (fsm-debug-output "Using data from enter function")
 336                 (plist-put (cddr fsm) :state-data newer-state-data)
 337                 (fsm-maybe-change-timer fsm newer-timeout))
 338             ((debug error)
 339              (fsm-debug-output "Didn't work: %S" e)))))
 340
 341       (let ((deferred (nreverse (plist-get (cddr fsm) :deferred))))
 342         (setf (cddr fsm)
 343               (plist-put (cddr fsm) :deferred nil))
 344         (dolist (event deferred)
 345           (apply 'fsm-send-sync fsm event))))))
 346
 347 (defun fsm-send-sync (fsm event &optional callback)
 348   "Send EVENT to FSM synchronously.
 349 If the state machine generates a response, eventually call
 350 CALLBACK with the response as only argument."
 351   (save-match-data
 352     (let* ((fsm-name (second fsm))
 353            (state (plist-get (cddr fsm) :state))
 354            (state-data (plist-get (cddr fsm) :state-data))
 355            (state-fn (gethash state (get fsm-name :fsm-event))))
 356       ;; If the event is a list, output only the car, to avoid an
 357       ;; overflowing debug buffer.
 358       (fsm-debug-output "Sent %S to %s in state %s"
 359                         (or (car-safe event) event) fsm-name state)
 360       (let ((result (condition-case e
 361                         (funcall state-fn fsm state-data event
 362                                  (or callback 'ignore))
 363                       ((debug error) (cons :error-signaled e)))))
 364         ;; Special case for deferring an event until next state change.
 365         (cond
 366          ((eq result :defer)
 367           (let ((deferred (plist-get (cddr fsm) :deferred)))
 368             (plist-put (cddr fsm) :deferred
 369                        (cons (list event callback) deferred))))
 370          ((null result)
 371           (fsm-debug-output "Warning: event %S ignored in state %s/%s" event fsm-name state))
 372          ((eq (car-safe result) :error-signaled)
 373           (fsm-debug-output "Error in %s/%s: %s"
 374                             fsm-name state
 375                             (error-message-string (cdr result))))
 376          (t
 377           (destructuring-bind (new-state new-state-data &optional timeout) result
 378             (fsm-update fsm new-state new-state-data timeout))))))))
 379
 380 (defun fsm-call (fsm event)
 381   "Send EVENT to FSM synchronously, and wait for a reply.
 382 Return the reply.
 383 `with-timeout' might be useful."
 384   (lexical-let (reply)
 385     (fsm-send-sync fsm event (lambda (r) (setq reply (list r))))
 386     (while (null reply)
 387       (fsm-sleep fsm 1))
 388     (car reply)))
 389
 390 (defun fsm-make-filter (fsm)
 391   "Return a filter function that sends events to FSM.
 392 Events sent are of the form (:filter PROCESS STRING)."
 393   (lexical-let ((fsm fsm))
 394     (lambda (process string)
 395       (fsm-send-sync fsm (list :filter process string)))))
 396
 397 (defun fsm-make-sentinel (fsm)
 398   "Return a sentinel function that sends events to FSM.
 399 Events sent are of the form (:sentinel PROCESS STRING)."
 400   (lexical-let ((fsm fsm))
 401      (lambda (process string)
 402        (fsm-send-sync fsm (list :sentinel process string)))))
 403
 404 (defun fsm-sleep (fsm secs)
 405   "Sleep up to SECS seconds in a way that lets FSM receive events."
 406   (funcall (plist-get (cddr fsm) :sleep) secs))
 407
 408 (defun fsm-get-state-data (fsm)
 409   "Return the state data of FSM.
 410 Note the absence of a set function.  The fsm should manage its
 411 state data itself; other code should just send messages to it."
 412   (plist-get (cddr fsm) :state-data))
 413
 414 (provide 'fsm)
 415
 416 ;;; fsm.el ends here