state machine minilanguage - first cut (buggy)

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]
+(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))))))