From 456a46bc93ae9961fe6e0c88bf77b73eae2a7199 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 1 Sep 2013 19:38:35 +0200 Subject: [PATCH] composable state machines --- CSM.ml | 216 +++++++++++++++++++++++++++++++++++++++++++++++ CSM.mli | 130 ++++++++++++++++++++++++++++ containers.mllib | 1 + 3 files changed, 347 insertions(+) create mode 100644 CSM.ml create mode 100644 CSM.mli diff --git a/CSM.ml b/CSM.ml new file mode 100644 index 00000000..1865041a --- /dev/null +++ b/CSM.ml @@ -0,0 +1,216 @@ +(* +copyright (c) 2013, simon cruanes +all rights reserved. + +redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. redistributions in binary +form must reproduce the above copyright notice, this list of conditions and the +following disclaimer in the documentation and/or other materials provided with +the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(** {1 Composable State Machines} *) + +(** {2 Basic interface} *) + +type 'state t = { + id : int; + mutable state : 'state; + mutable callbacks : 'state callback array; + mutable callbacks_num : int; +} (** State machine, whose states are of the type 'state, + and that changes state upon events of the type 'event. *) + +and 'a sm = 'a t + +and 'event sink = 'event -> unit + +and 'a transition = + | TransitionTo of 'a + | TransitionStay + (** A transition of a state machine whose states are + of type 'a *) + +and 'a callback = 'a -> 'a -> bool + (** A callback that is called during a transition between two 'a states *) + +and task_queue = (unit -> unit) Queue.t + (** Queue of tasks to process *) + +type poly_ref = + | PolyRef : 'a t -> poly_ref + (** Polymorphic reference to a state machine *) + +module SMSet = Set.Make(struct + type t = poly_ref + let compare st1_ref st2_ref = + match st1_ref, st2_ref with + | PolyRef s1, PolyRef s2 -> s1.id - s2.id +end) + +let __id = ref 0 +let __roots = ref SMSet.empty +let __default_callback _ _ = true +let __queue = Queue.create () (* queue to use to process events *) +let __fresh_id () = + let n = !__id in + incr __id; + n + +let make_root st = + __roots := SMSet.add (PolyRef st) !__roots + +let remove_root st = + __roots := SMSet.remove (PolyRef st) !__roots + +(* make a transition *) +let _do_transition st new_state = + Queue.push + (fun () -> + let old_state = st.state in + st.state <- new_state; + for i = 0 to st.callbacks_num - 1 do + try + let keep = st.callbacks.(i) old_state new_state in + if not keep then begin + (* remove this callback *) + (if i < st.callbacks_num - 1 then + st.callbacks.(i) <- st.callbacks.(st.callbacks_num - 1)); + st.callbacks_num <- st.callbacks_num - 1; + end; + with e -> + () (* TODO: some global error handler? *) + done) + __queue + +(* create a SM *) +let mk_sm ~init = + let st = { + id = __fresh_id (); + state = init; + callbacks = Array.make 4 __default_callback; + callbacks_num = 0; + } in + st + +(* create a SM with a transition function *) +let create ?(root=false) ~init ~trans = + let st = mk_sm ~init in + let sink e = match trans st.state e with + | TransitionStay -> () + | TransitionTo new_state -> + _do_transition st new_state + in + (if root then make_root st); + st, sink + +let id st = st.id + +let state st = st.state + +let eq st1 st2 = st1.id = st2.id + +let hash st = st.id + +let compare st1 st2 = st1.id - st2.id + +let register_while st callback = + (if st.callbacks_num = Array.length st.callbacks + then begin + let a = Array.make (2*st.callbacks_num) __default_callback in + Array.blit st.callbacks 0 a 0 st.callbacks_num; + st.callbacks <- a + end); + st.callbacks.(st.callbacks_num) <- callback; + st.callbacks_num <- st.callbacks_num + 1; + () + +let register st callback = + register_while st (fun a b -> callback a b; true) + +let connect st sink = + register_while st (fun _ new_state -> sink new_state; true) + +(** {2 Combinators} *) + +let map st f = + let st' = mk_sm ~init:(f st.state) in + let a = Weak.create 1 in + Weak.set a 0 (Some st'); + register_while st + (fun _ new_state -> + match Weak.get a 0 with + | None -> false + | Some st' -> + _do_transition st' (f new_state); + true); + st' + +let filter st p = + let st' = mk_sm ~init:st.state in + let a = Weak.create 1 in + Weak.set a 0 (Some st'); + register_while st + (fun _ new_state -> + if p + then begin match Weak.get a 0 with + | None -> false + | Some st' -> + _do_transition st' new_state; + true + end else true); + st' + +let seq_list l = + let init = List.map state l in + let _array = Array.of_list init in + let st' = mk_sm ~init in + let a = Weak.create 1 in + Weak.set a 0 (Some st'); + List.iteri + (fun i st -> + register_while st + (fun _ new_state -> + match Weak.get a 0 with + | None -> false + | Some st' -> + _array.(i) <- new_state; + _do_transition st' (Array.to_list _array); + true)) + l; + st' + +(** {2 Unix wrappers} *) + +module Unix = struct + type fd_state = + | FD_wait of Unix.file_descr + | FD_ready_read of Unix.file_descr + | FD_ready_write of Unix.file_descr + | FD_exc_condition of Unix.file_descr + + let select read write exc = + assert false + + let run () = + while not (Queue.is_empty __queue) do + let task = Queue.pop __queue in + task () + done; + () +end + diff --git a/CSM.mli b/CSM.mli new file mode 100644 index 00000000..6485e38a --- /dev/null +++ b/CSM.mli @@ -0,0 +1,130 @@ +(* +copyright (c) 2013, simon cruanes +all rights reserved. + +redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. redistributions in binary +form must reproduce the above copyright notice, this list of conditions and the +following disclaimer in the documentation and/or other materials provided with +the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(** {1 Composable State Machines} *) + +(** This module defines state machines that should help design applications + with a more explicit control of state (e.g. for networking applications. + It is {b not} thread-safe. +*) + +(** {2 Basic interface} *) + +type 'state t + (** State machine, whose states are of the type 'state, + and that changes state upon events of the type 'event. *) + +type 'event sink + (** Something that reacts to events of type 'events *) + +type 'a transition = + | TransitionTo of 'a + | TransitionStay + (** A transition of a state machine whose states are + of type 'a *) + +val create : ?root:bool -> + init:'state -> + trans:('state -> 'event -> 'state transition) -> + 'state t * 'event sink + (** Creation of a state machine with an initial state and a + given transition function. [root] specifies whether the FSM should + be a GC root and stay alive (default false). + This creates both a state machine and a way to send + events to it. *) + +val state : 'state t -> 'state + (** Current state of a machine *) + +val id : _ t -> int + (** Unique ID of a state machine *) + +val eq : _ t -> _ t -> bool + +val hash : _ t -> int + +val compare : _ t -> _ t -> int + +val register_while : 'state t -> ('state -> 'state -> bool) -> unit + (** The given callback will be called upon every state change of + the given state machine with both the old and the new states, + while it returns [true]. When it returns [false], the + callback will no longer be referenced nor called. + *) + +val register : 'state t -> ('state -> 'state -> unit) -> unit + (** Register the given callback forever. *) + +val connect : 'a t -> 'a sink -> unit + (** [connect st sink] connects state changes of [st] to the sink. The + sink is given only the new state of [st]. *) + +val send : 'event sink -> 'event -> unit + (** Trigger an event. This function will not return until no transitions + remain for processing, which means it can take an arbitrary amount of time to + run. *) + +(** {2 Combinators} *) + +val map : 'a t -> ('a -> 'b) -> 'b t + (** Map the states from the given state machine to new states. *) + +val filter : 'a t -> ('a -> bool) -> 'a t + (** [filter st p] behaves like [st], but only keeps transitions + {b to} states that satisfy the given predicate. *) + +val seq_list : 'state t list -> 'state list t + (** Aggregate of the states of several machines *) + +(** {2 GC behavior} *) + +val make_root : _ t -> unit + (** Make the given state machine alive w.r.t. the GC. It will not be + collected *) + +val remove_root : _ t -> unit + (** The given state machine is no longer a GC root. *) + +(** {2 Unix wrappers} *) + +module Unix : sig + type fd_state = + | FD_wait of Unix.file_descr + | FD_ready_read of Unix.file_descr + | FD_ready_write of Unix.file_descr + | FD_exc_condition of Unix.file_descr + + val select : Unix.file_descr list -> + Unix.file_descr list -> + Unix.file_descr list -> + float -> + (fd_state list * fd_state list * fd_state list) t + (** Wrapper for {! Unix.select} as a state machine. *) + + val run : unit -> unit + (** Main function, doesn't return. It waits for unix events, + runs state machines until everything has been processed, and + waits for unix events again. *) +end diff --git a/containers.mllib b/containers.mllib index ce087f15..4a809eca 100644 --- a/containers.mllib +++ b/containers.mllib @@ -26,3 +26,4 @@ UnionFind SmallSet Leftistheap AbsSet +CSM