fix state machine bugs

This commit is contained in:
Jeremy Penner 2013-05-04 00:18:22 -04:00
parent 5548363a06
commit 69c533ceec

View file

@ -29,7 +29,7 @@
::id (::id stm) ::id (::id stm)
::return-to (::return-to stm)))) ::return-to (::return-to stm))))
(defn goto [stm state & [value]] (defn goto [stm state & [value]]
(assoc (stm-from-value stm value) ::state state)) (assoc (stm-from-value stm value) ::state state))
(defn post-event [stm event] (defn post-event [stm event]
@ -49,8 +49,8 @@
(defn- process-state [stm step] (defn- process-state [stm step]
;(println step (::state stm) (::value stm) (seq (::events stm))) ;(println step (::state stm) (::value stm) (seq (::events stm)))
(case step (case step
:enter :enter
(let [[stmnew stepnext] (transition :return-from enter-state stm)] (let [[stmnew stepnext] (transition :return-from enter-state stm)]
(recur stmnew stepnext)) (recur stmnew stepnext))
:return-from :return-from
(if (is-end-state stm) (if (is-end-state stm)
@ -75,10 +75,10 @@
stm)) stm))
stm)) stm))
(defn start [stmid & [value]] (defn start [stmid & [value]]
(let [stm (assoc (or value {}) (let [stm (assoc (or value {})
::id stmid ::id stmid
::state (start-state-for-stm stmid) ::state (start-state-for-stm stmid)
::events clojure.lang.PersistentQueue/EMPTY)] ::events clojure.lang.PersistentQueue/EMPTY)]
(process-state stm :enter))) (process-state stm :enter)))
@ -114,9 +114,9 @@
`(~handlertype ~opts ~@args))) `(~handlertype ~opts ~@args)))
(defn- normalize-statespec [statespec statedefault] (defn- normalize-statespec [statespec statedefault]
(let [state-defined (let [state-defined
(keyword? (first statespec)) (keyword? (first statespec))
[state args] [state args]
(if state-defined (if state-defined
[(first statespec) (next statespec)] [(first statespec) (next statespec)]
[statedefault statespec]) [statedefault statespec])
@ -130,23 +130,23 @@
`(~state ~opts ~@(map #(normalize-handlerspec % opts) handlerspecs)))) `(~state ~opts ~@(map #(normalize-handlerspec % opts) handlerspecs))))
(defn- states-from-specs [statespecs start-state] (defn- states-from-specs [statespecs start-state]
(loop [states [] (loop [states []
statespecs statespecs statespecs statespecs
statenext start-state statenext start-state
statenextindex 0] statenextindex 0]
(if (empty? statespecs) (if (empty? statespecs)
(conj states :end) (conj states :end)
(let [statespec (let [statespec
(first statespecs) (first statespecs)
given-state given-state
(if (keyword? (first statespec)) (if (keyword? (first statespec))
(first statespec)) (first statespec))
state state
(or given-state (keyword (str (name statenext) (if (= statenextindex 0) "" statenextindex))))] (or given-state (keyword (str (name statenext) (if (= statenextindex 0) "" statenextindex))))]
(recur (conj states state) (recur (conj states state)
(next statespecs) (next statespecs)
(if given-state given-state statenext) (if given-state given-state statenext)
(if given-state 1 (+ statenextindex 1))))))) (if given-state 1 (+ statenextindex 1)))))))
@ -186,8 +186,8 @@
((:fnhandler handler) stm event)))) ((:fnhandler handler) stm event))))
(defn- out-stmfnbody [body opts statenext] (defn- out-stmfnbody [body opts statenext]
`[[& args#] (call-stmfunc (fn ~@body) ~opts args# ~statenext)]) `[[& args#] (call-stmfunc (fn ~@body) ~opts args# ~statenext)])
(defn- out-def-handler [stmid state optsdefault statenext [handlertype opts & args]] (defn- out-def-handler [stmid state optsdefault statenext [handlertype opts & args]]
(let [opts (into optsdefault opts)] (let [opts (into optsdefault opts)]
(case handlertype (case handlertype
@ -196,11 +196,11 @@
::exit ::exit
[`(defmethod exit-state [~stmid ~state] ~@(out-stmfnbody opts statenext 1 args))] [`(defmethod exit-state [~stmid ~state] ~@(out-stmfnbody opts statenext 1 args))]
::call ::call
[(let [[stmidcall & body] [(let [[stmidcall & body]
(if (keyword? (first args)) (if (keyword? (first args))
[(first args) [(gensym)] nil] [(first args) [(gensym)] nil]
(first args))] (first args))]
`(defmethod on-call [~stmid ~state] [stm#] `(defmethod on-call [~stmid ~state] [stm#]
(start ~stmidcall ((fn ~@(ensure-fnbody 1 body)) stm#))))] (start ~stmidcall ((fn ~@(ensure-fnbody 1 body)) stm#))))]
[]))) [])))
@ -211,7 +211,7 @@
::call ::call
[(let [body (next args)] [(let [body (next args)]
`{:eventtype ::return :fnhandler (fn ~@(out-stmfnbody body opts statenext))})] `{:eventtype ::return :fnhandler (fn ~@(out-stmfnbody body opts statenext))})]
[(let [[fnguard body] (if (vector? (first args)) [nil args] args)] [(let [[fnguard & body] (if (vector? (first args)) [nil args] args)]
`{:eventtype ~handlertype :fnguard ~fnguard :fnhandler (fn ~@(out-stmfnbody (ensure-fnbody 2 body) opts statenext))})]))) `{:eventtype ~handlertype :fnguard ~fnguard :fnhandler (fn ~@(out-stmfnbody (ensure-fnbody 2 body) opts statenext))})])))
(defn- out-def-state [stmid [state opts & handlerspecs] statenext] (defn- out-def-state [stmid [state opts & handlerspecs] statenext]
@ -220,12 +220,12 @@
[`(let [handlers# [~@(apply concat (map #(out-event-handler stmid state opts statenext %) handlerspecs))]] [`(let [handlers# [~@(apply concat (map #(out-event-handler stmid state opts statenext %) handlerspecs))]]
(defmethod on-event [~stmid ~state] [stm# event#] (defmethod on-event [~stmid ~state] [stm# event#]
(call-eventhandlers stm# event# handlers#)))])) (call-eventhandlers stm# event# handlers#)))]))
(defmacro defstm [stmid & args] (defmacro defstm [stmid & args]
(let [stmopts (let [stmopts
{:start-state :start} {:start-state :start}
[stmopts statespecs] [stmopts statespecs]
(if (map? (first args)) (if (map? (first args))
[(into stmopts (first args)) (next args)] [(into stmopts (first args)) (next args)]
[stmopts args]) [stmopts args])
states states
@ -234,7 +234,7 @@
(map normalize-statespec statespecs states) (map normalize-statespec statespecs states)
endstates endstates
(filter #(:is-end-state (second %)) statespecs) (filter #(:is-end-state (second %)) statespecs)
sstmid sstmid
(gensym "stmid")] (gensym "stmid")]
`(let [~sstmid ~stmid] `(let [~sstmid ~stmid]
(remove-stm ~sstmid) (remove-stm ~sstmid)