diff --git a/src/hottub/stm.clj b/src/hottub/stm.clj index bfa5e7a..32881b2 100644 --- a/src/hottub/stm.clj +++ b/src/hottub/stm.clj @@ -4,6 +4,7 @@ (defmulti enter-state dispatch-id-state) (defmulti exit-state dispatch-id-state) (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 start-state-for-stm (fn [stmid] stmid)) @@ -12,6 +13,8 @@ (defmethod enter-state :default [stm] nil) (defmethod exit-state :default [stm]) (defmethod on-event :default [stm event] nil) +(defmethod event-matches :default [stm eventtype event] (= eventtype (:type event))) + (defmethod on-call :default [stm] nil) (defmethod start-state-for-stm :default [stmid] :start) (defmethod is-end-state :default [stm] (= (:state stm) :end)) @@ -68,7 +71,7 @@ (defn start [stmid & [value]] (let [stm {:id stmid :state (start-state-for-stm stmid) - :value value + :value (or value {}) :events clojure.lang.PersistentQueue/EMPTY}] (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]] (remove-stm-method stmid multifn))) -(defmacro defstm [stmid & body] - `(doto ~stmid - (remove-stm) - ~@body)) +(defn- normalize-handlerspec [handlerspec optsdefault] + (let [[handlertype args] + [(first handlerspec) (next handlerspec)] + 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]) \ No newline at end of file +(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))))))