state machine minilanguage - first cut (buggy)
This commit is contained in:
parent
eb089cacbc
commit
4b6519aa13
|
@ -4,6 +4,7 @@
|
||||||
(defmulti enter-state dispatch-id-state)
|
(defmulti enter-state dispatch-id-state)
|
||||||
(defmulti exit-state dispatch-id-state)
|
(defmulti exit-state dispatch-id-state)
|
||||||
(defmulti on-event (fn [stm event] (dispatch-id-state stm)))
|
(defmulti on-event (fn [stm event] (dispatch-id-state stm)))
|
||||||
|
(defmulti event-matches (fn [stm eventtype event] (:id stm)))
|
||||||
(defmulti on-call dispatch-id-state)
|
(defmulti on-call dispatch-id-state)
|
||||||
|
|
||||||
(defmulti start-state-for-stm (fn [stmid] stmid))
|
(defmulti start-state-for-stm (fn [stmid] stmid))
|
||||||
|
@ -12,6 +13,8 @@
|
||||||
(defmethod enter-state :default [stm] nil)
|
(defmethod enter-state :default [stm] nil)
|
||||||
(defmethod exit-state :default [stm])
|
(defmethod exit-state :default [stm])
|
||||||
(defmethod on-event :default [stm event] nil)
|
(defmethod on-event :default [stm event] nil)
|
||||||
|
(defmethod event-matches :default [stm eventtype event] (= eventtype (:type event)))
|
||||||
|
|
||||||
(defmethod on-call :default [stm] nil)
|
(defmethod on-call :default [stm] nil)
|
||||||
(defmethod start-state-for-stm :default [stmid] :start)
|
(defmethod start-state-for-stm :default [stmid] :start)
|
||||||
(defmethod is-end-state :default [stm] (= (:state stm) :end))
|
(defmethod is-end-state :default [stm] (= (:state stm) :end))
|
||||||
|
@ -68,7 +71,7 @@
|
||||||
(defn start [stmid & [value]]
|
(defn start [stmid & [value]]
|
||||||
(let [stm {:id stmid
|
(let [stm {:id stmid
|
||||||
:state (start-state-for-stm stmid)
|
:state (start-state-for-stm stmid)
|
||||||
:value value
|
:value (or value {})
|
||||||
:events clojure.lang.PersistentQueue/EMPTY}]
|
:events clojure.lang.PersistentQueue/EMPTY}]
|
||||||
(process-state stm :enter)))
|
(process-state stm :enter)))
|
||||||
|
|
||||||
|
@ -84,9 +87,152 @@
|
||||||
(doseq [multifn [enter-state exit-state on-event on-call start-state-for-stm is-end-state]]
|
(doseq [multifn [enter-state exit-state on-event on-call start-state-for-stm is-end-state]]
|
||||||
(remove-stm-method stmid multifn)))
|
(remove-stm-method stmid multifn)))
|
||||||
|
|
||||||
(defmacro defstm [stmid & body]
|
(defn- normalize-handlerspec [handlerspec optsdefault]
|
||||||
`(doto ~stmid
|
(let [[handlertype args]
|
||||||
(remove-stm)
|
[(first handlerspec) (next handlerspec)]
|
||||||
~@body))
|
optsimplicit
|
||||||
|
(if (:implicit-state optsdefault)
|
||||||
|
{:returns-value true
|
||||||
|
:advances (not= handlertype ::enter)
|
||||||
|
:pass-next-state false}
|
||||||
|
{:returns-value false
|
||||||
|
:advances false
|
||||||
|
:pass-next-state false})
|
||||||
|
[optsoverridden args]
|
||||||
|
(if (map? (first args))
|
||||||
|
[(first args) (next args)]
|
||||||
|
[{} args])
|
||||||
|
opts
|
||||||
|
(-> optsimplicit
|
||||||
|
(into optsdefault)
|
||||||
|
(into optsoverridden))]
|
||||||
|
`(~handlertype ~opts ~@args)))
|
||||||
|
|
||||||
(defmacro defseries [stmid [startstate afterstate] & statedefs])
|
(defn- normalize-statespec [statespec statedefault]
|
||||||
|
(let [state-defined
|
||||||
|
(keyword? (first statespec))
|
||||||
|
[state args]
|
||||||
|
(if state-defined
|
||||||
|
[(first statespec) (next statespec)]
|
||||||
|
[statedefault statespec])
|
||||||
|
opts
|
||||||
|
{:implicit-state (not state-defined)
|
||||||
|
:is-end-state false}
|
||||||
|
[opts handlerspecs]
|
||||||
|
(if (map? (first args))
|
||||||
|
[(into opts (first args)) (next args)]
|
||||||
|
[opts args])]
|
||||||
|
`(~state ~opts ~@(map #(normalize-handlerspec % opts) handlerspecs))))
|
||||||
|
|
||||||
|
(defn- states-from-specs [statespecs start-state]
|
||||||
|
(loop [states []
|
||||||
|
statespecs statespecs
|
||||||
|
statenext start-state
|
||||||
|
statenextindex 0]
|
||||||
|
|
||||||
|
(if (empty? statespecs)
|
||||||
|
(conj states :end)
|
||||||
|
(let [statespec
|
||||||
|
(first statespecs)
|
||||||
|
given-state
|
||||||
|
(if (keyword? (first statespec))
|
||||||
|
(first statespec))
|
||||||
|
state
|
||||||
|
(or given-state (keyword (str (name statenext) (if (= statenextindex 0) "" statenextindex))))]
|
||||||
|
|
||||||
|
(recur (conj states state)
|
||||||
|
(next statespecs)
|
||||||
|
(if given-state given-state statenext)
|
||||||
|
(if given-state 1 (+ statenextindex 1)))))))
|
||||||
|
|
||||||
|
(defn- out-def-end-state [stmid statespec]
|
||||||
|
`(defmethod is-end-state [~stmid ~(first statespec)] true))
|
||||||
|
|
||||||
|
(defn- ensure-fnbody [numargs body]
|
||||||
|
(let [[params exprs]
|
||||||
|
(case (count body)
|
||||||
|
0 [[] [nil]]
|
||||||
|
1 [[] body]
|
||||||
|
body)
|
||||||
|
params
|
||||||
|
(if (< (count params) numargs)
|
||||||
|
(into params (repeatedly (- numargs (count params)) #(gensym)))
|
||||||
|
params)]
|
||||||
|
[params exprs]))
|
||||||
|
|
||||||
|
(defn call-stmfunc [fn opts args statenext]
|
||||||
|
(let [stm (first args)
|
||||||
|
args (if (:returns-value opts) (cons (value stm) (next args)) args)
|
||||||
|
args (if (:pass-next-state opts) (concat args [statenext]) args)
|
||||||
|
result (apply fn args)
|
||||||
|
stm (if (:returns-value opts) (goto stm (state stm) result) (or result stm))
|
||||||
|
stm (if (:advances opts) (goto stm statenext (value stm)))]
|
||||||
|
stm))
|
||||||
|
|
||||||
|
(defn- handler-matches [stm handler event]
|
||||||
|
(and (event-matches stm (:eventtype handler) event)
|
||||||
|
(if-let [fnguard (:fnguard handler)]
|
||||||
|
(fnguard stm event)
|
||||||
|
true)))
|
||||||
|
|
||||||
|
(defn call-eventhandlers [stm event handlers]
|
||||||
|
(let [matchinghandlers (filter #(handler-matches stm % event) handlers)
|
||||||
|
handler (first matchinghandlers)]
|
||||||
|
(if handler
|
||||||
|
((:fnhandler handler) stm event))))
|
||||||
|
|
||||||
|
(defn- out-stmfnbody [body opts statenext]
|
||||||
|
`[[& args#] (call-stmfunc (fn ~@body) ~opts args# ~statenext)])
|
||||||
|
|
||||||
|
(defn- out-def-handler [stmid state optsdefault statenext [handlertype opts & args]]
|
||||||
|
(let [opts (into optsdefault opts)]
|
||||||
|
(case handlertype
|
||||||
|
::enter
|
||||||
|
[`(defmethod enter-state [~stmid ~state] ~@(out-stmfnbody (ensure-fnbody 1 args) opts statenext))]
|
||||||
|
::exit
|
||||||
|
[`(defmethod exit-state [~stmid ~state] ~@(out-stmfnbody opts statenext 1 args))]
|
||||||
|
::call
|
||||||
|
[(let [[stmidcall & body]
|
||||||
|
(if (keyword? (first args))
|
||||||
|
[(first args) [(gensym)] nil]
|
||||||
|
(first args))]
|
||||||
|
`(defmethod on-call [~stmid ~state] [stm#]
|
||||||
|
(start ~stmidcall ((fn ~@(ensure-fnbody 1 body)) (value stm#)))))]
|
||||||
|
[])))
|
||||||
|
|
||||||
|
(defn- out-event-handler [stmid state optsdefault statenext [handlertype opts & args]]
|
||||||
|
(let [opts (into optsdefault opts)]
|
||||||
|
(case handlertype
|
||||||
|
(::enter, ::exit) []
|
||||||
|
::call
|
||||||
|
[(let [body (next args)]
|
||||||
|
`{:eventtype ::return :fnhandler (fn ~@(out-stmfnbody body opts statenext))})]
|
||||||
|
[(let [[fnguard body] (if (vector? (first args)) [nil args] args)]
|
||||||
|
`{:eventtype ~handlertype :fnguard ~fnguard :fnhandler (fn ~@(out-stmfnbody (ensure-fnbody 2 body) opts statenext))})])))
|
||||||
|
|
||||||
|
(defn- out-def-state [stmid [state opts & handlerspecs] statenext]
|
||||||
|
(concat
|
||||||
|
(apply concat (map #(out-def-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#]
|
||||||
|
(call-eventhandlers stm# event# handlers#)))]))
|
||||||
|
|
||||||
|
(defmacro defstm [stmid & args]
|
||||||
|
(let [stmopts
|
||||||
|
{:start-state :start}
|
||||||
|
[stmopts statespecs]
|
||||||
|
(if (map? (first args))
|
||||||
|
[(into stmopts (first args)) (next args)]
|
||||||
|
[stmopts args])
|
||||||
|
states
|
||||||
|
(states-from-specs statespecs (:start-state stmopts))
|
||||||
|
statespecs
|
||||||
|
(map normalize-statespec statespecs states)
|
||||||
|
endstates
|
||||||
|
(filter #(:is-end-state (second %)) statespecs)
|
||||||
|
sstmid
|
||||||
|
(gensym "stmid")]
|
||||||
|
`(let [~sstmid ~stmid]
|
||||||
|
(remove-stm ~sstmid)
|
||||||
|
~@(map #(out-def-end-state sstmid %) endstates)
|
||||||
|
~@(reduce concat (map #(out-def-state sstmid %1 %2) statespecs (next states))))))
|
||||||
|
|
Loading…
Reference in a new issue