-
Notifications
You must be signed in to change notification settings - Fork 4
/
v20150901_impl.cljc
811 lines (752 loc) · 39 KB
/
v20150901_impl.cljc
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
(ns com.fulcrologic.statecharts.algorithms.v20150901-impl
"An implementation of the W3C SCXML Recommended Spec from 2015-09-01.
Uses an imperative style (internally) to match the pseudocode in the standard for easier translation,
verification, and avoidance of subtle differences in implementation."
#?(:cljs (:require-macros [com.fulcrologic.statecharts.algorithms.v20150901-impl
:refer [in-state-context
with-processing-context]]))
(:require
[clojure.set :as set]
[clojure.spec.alpha :as s]
[com.fulcrologic.guardrails.core :refer [>defn => ?]]
[com.fulcrologic.statecharts :as sc]
[com.fulcrologic.statecharts.data-model.operations :as ops]
[com.fulcrologic.statecharts.elements :as elements]
[com.fulcrologic.statecharts.environment :as env]
[com.fulcrologic.statecharts.events :as evts :refer [new-event]]
[com.fulcrologic.statecharts.protocols :as sp]
[com.fulcrologic.statecharts.specs]
[com.fulcrologic.statecharts.chart :as chart]
[com.fulcrologic.statecharts.util :refer [genid new-uuid]]
[taoensso.timbre :as log]))
#?(:clj
(defmacro with-processing-context [env & body]
`(let [vwmem# (get ~env ::sc/vwmem)]
(vswap! vwmem# (fn [m#] (merge
{::sc/enabled-transitions #{}
::sc/states-to-invoke #{}
;; This belongs elsewhere, I think
::sc/internal-queue (com.fulcrologic.statecharts.util/queue)}
m#)))
(do ~@body)
(vswap! vwmem# dissoc ::sc/enabled-transitions ::sc/states-to-invoke ::sc/internal-queue))))
#?(:clj
(s/fdef with-processing-context
:args (s/cat :env symbol? :body (s/* any?))))
#?(:clj
(defmacro in-state-context
"Change the `env` context to the given state element (you can supply id or element itself). Runs the `body` with
the update env, and returns the last expression of the body. `env` changes to context
are not visible outside of this block."
[env-sym state-or-id & body]
`(let [m# (get ~env-sym ::sc/statechart)
id# (chart/element-id m# ~state-or-id)
~env-sym (assoc ~env-sym ::sc/context-element-id id#)]
~@body)))
(s/fdef in-state-context
:ret any?
:args (s/cat :s symbol? :sid any? :body (s/* any?)))
(defn !?
"Returns `value` if not nil, or runs `expr` and returns that as the value. Returns nil if both are nil."
[{::sc/keys [execution-model] :as env} value expr]
(cond
(fn? value) (sp/run-expression! execution-model env value)
(not (nil? value)) value
(not (nil? expr)) (sp/run-expression! execution-model env expr)
:else nil))
(defn- named-data
"Convert a element namelist arg into a map of data from the data model."
[{::sc/keys [data-model] :as env} namelist]
(if (map? namelist)
(reduce-kv
(fn [acc k location]
(let [v (sp/get-at data-model env location)]
(if (nil? v)
acc
(assoc acc k v))))
{}
namelist)
{}))
(defn- run-expression! [{::sc/keys [event-queue execution-model] :as env} expr]
(try
(sp/run-expression! execution-model env expr)
(catch #?(:clj Throwable :cljs :default) e
(log/error e "Expression failure")
(let [session-id (env/session-id env)]
(sp/send! event-queue env {:event :error.execution
:send-id session-id
:data {:error e}
:source-session-id session-id})))))
(>defn condition-match
[{::sc/keys [statechart] :as env} element-or-id]
[::sc/processing-env ::sc/element-or-id => boolean?]
(let [{:keys [cond]} (chart/element statechart element-or-id)]
(if (nil? cond)
true
(boolean (run-expression! env cond)))))
(>defn session-id
"Returns the unique session id from an initialized `env`."
[{::sc/keys [vwmem]}]
[::sc/processing-env => ::sc/session-id]
(::sc/session-id @vwmem))
(>defn in-final-state?
"Returns true if `non-atomic-state` is completely done."
[{::sc/keys [statechart vwmem] :as env} non-atomic-state]
[::sc/processing-env (? ::sc/element-or-id) => boolean?]
(boolean
(cond
(chart/compound-state? statechart non-atomic-state) (some
(fn [s] (and (chart/final-state? statechart s) (contains? (::sc/configuration @vwmem) s)))
(chart/child-states statechart non-atomic-state))
(chart/parallel-state? statechart non-atomic-state) (every?
(fn [s] (in-final-state? env s))
(chart/child-states statechart non-atomic-state))
:else false)))
(declare add-descendant-states-to-enter!)
(>defn raise
"Add an event to the internal (working memory) event queue."
[{::sc/keys [vwmem]} event]
[::sc/processing-env ::sc/event-or-name => nil?]
(vswap! vwmem update ::sc/internal-queue conj (evts/new-event event))
nil)
(>defn add-ancestor-states-to-enter! [{::sc/keys [statechart] :as env} state ancestor
states-to-enter states-for-default-entry default-history-content]
[::sc/processing-env ::sc/element-or-id ::sc/element-or-id volatile? volatile? volatile? => nil?]
(doseq [anc (chart/get-proper-ancestors statechart state ancestor)]
(vswap! states-to-enter conj (chart/element-id statechart anc))
(when (chart/parallel-state? statechart anc)
(doseq [child (chart/child-states statechart anc)]
(when-not (some (fn [s] (chart/descendant? statechart s child)) @states-to-enter)
(add-descendant-states-to-enter! env child states-to-enter
states-for-default-entry default-history-content)))))
nil)
(>defn add-descendant-states-to-enter! [{::sc/keys [statechart vwmem] :as env}
state states-to-enter states-for-default-entry default-history-content]
[::sc/processing-env ::sc/element-or-id volatile? volatile? volatile? => nil?]
(letfn [(add-elements! [target parent]
(doseq [s target]
(add-descendant-states-to-enter! env s states-to-enter
states-for-default-entry default-history-content))
(doseq [s target]
(add-ancestor-states-to-enter! env s parent states-to-enter
states-for-default-entry default-history-content)))]
(let [{:keys [id parent] :as state} (chart/element statechart state)]
(if (chart/history-element? statechart state)
(if-let [previously-active-states (get (::sc/history-value @vwmem) id)]
(add-elements! previously-active-states parent)
(let [{:keys [children target]} (chart/transition-element statechart state)]
(when (seq children) (vswap! default-history-content assoc parent children))
(add-elements! target parent)))
; not a history element
(do
(vswap! states-to-enter conj (chart/element-id statechart state))
(if (chart/compound-state? statechart state)
(let [target (->> (chart/initial-element statechart state) (chart/transition-element statechart) :target)]
(vswap! states-for-default-entry conj (chart/element-id statechart state))
(add-elements! target state))
(if (chart/parallel-state? statechart state)
(doseq [child (chart/child-states statechart state)]
(when-not (some (fn [s] (chart/descendant? statechart s child)) @states-to-enter)
(add-descendant-states-to-enter! env child states-to-enter
states-for-default-entry default-history-content))))))))
nil))
(>defn get-effective-target-states
[{::sc/keys [statechart vwmem] :as env} t]
[::sc/processing-env ::sc/element-or-id => (s/every ::sc/element-or-id :kind set?)]
(let [{::sc/keys [history-value]} @vwmem]
(reduce
(fn [targets s]
(log/spy :trace "target" s)
(let [{:keys [id] :as s} (log/spy :trace "target element" (chart/element statechart s))]
(cond
(and
(chart/history-element? statechart s)
(contains? history-value id))
#_=> (set/union targets (get history-value id))
(chart/history-element? statechart s)
#_=> (let [default-transition (first (chart/transitions statechart s))] ; spec + validation. There will be exactly one
(set/union targets (get-effective-target-states env default-transition)))
:else (conj targets id))))
#{}
(log/spy :trace "target(s)"
(:target (chart/element statechart t))))))
(>defn get-transition-domain
[{::sc/keys [statechart] :as env} t]
[::sc/processing-env ::sc/element-or-id => (? ::sc/id)]
(let [tstates (get-effective-target-states env t)
tsource (chart/nearest-ancestor-state statechart t)]
(cond
(empty? tstates) nil
(and
(= :internal (:type t))
(chart/compound-state? statechart tsource)
(every? (fn [s] (chart/descendant? statechart s tsource)) tstates)) tsource
:else (:id (chart/find-least-common-compound-ancestor statechart (into (if tsource [tsource] []) tstates))))))
(>defn compute-entry-set!
"Returns [states-to-enter states-for-default-entry default-history-content]."
[{::sc/keys [vwmem statechart] :as env}]
[::sc/processing-env => (s/tuple set? set? map?)]
(let [states-to-enter (volatile! #{})
states-for-default-entry (volatile! #{})
default-history-content (volatile! {})
transitions (mapv (fn [t]
(or (chart/element statechart t)
(elements/transition {:target t})))
(::sc/enabled-transitions @vwmem))]
(doseq [{:keys [target] :as t} transitions]
(let [ancestor (chart/element-id statechart (get-transition-domain env t))]
(doseq [s target]
(add-descendant-states-to-enter! env s states-to-enter
states-for-default-entry default-history-content))
(doseq [s (get-effective-target-states env t)]
(add-ancestor-states-to-enter! env s ancestor states-to-enter
states-for-default-entry default-history-content))))
[@states-to-enter @states-for-default-entry @default-history-content]))
(>defn initialize-data-model!
"Initialize the data models in volatile working memory `wmem` for the given states, if necessary."
[{::sc/keys [statechart data-model] :as env} state]
[::sc/processing-env ::sc/element-or-id => nil?]
(log/trace "Initializing data model for" state)
(let [dm-eles (chart/get-children statechart state :data-model)
{:keys [src expr]} (chart/element statechart (first dm-eles))]
(when (> (count dm-eles) 1)
(log/warn "Too many data elements on" state))
(in-state-context env state
(cond
src (sp/load-data data-model env src)
(fn? expr) (let [ops (run-expression! env expr)]
(when (vector? ops)
(sp/update! data-model env {:ops ops})))
(map? expr) (sp/update! data-model env {:ops (ops/set-map-ops expr)})
:else (sp/update! data-model env {:ops (ops/set-map-ops {})})))
nil))
(declare execute!)
(defmulti execute-element-content!
"Multimethod. Extensible mechanism for running the content of elements on the state machine. Dispatch by :node-type
of the element itself."
(fn [_env element] (:node-type element)))
(defmethod execute-element-content! :default [env {:keys [children expr] :as element}]
(if (and (nil? expr) (empty? children))
(log/warn "There was no custom implementation to run content of " element)
(run-expression! env expr)))
(defmethod execute-element-content! :on-entry [env {:keys [id] :as element}]
(log/trace "on-entry " id)
(execute! env element))
(defmethod execute-element-content! :on-exit [env {:keys [id] :as element}]
(log/trace "on-exit " id)
(execute! env element))
(defmethod execute-element-content! :log [env {:keys [label expr]}]
(log/debug (or label "LOG") (run-expression! env expr)))
(defmethod execute-element-content! :raise [env {:keys [event]}]
(log/trace "Raise " event)
(raise env event))
(defmethod execute-element-content! :assign [env {:keys [location expr]}]
(let [v (run-expression! env expr)]
(log/trace "Assign" location " = " v)
(env/assign! env location v)))
(letfn [(send! [{::sc/keys [event-queue
data-model] :as env}
{:keys [id
idlocation
delay
delayexpr
namelist
content
event
eventexpr
target
targetexpr
type
typeexpr] :as _send-element}]
(let [event-name (!? env event eventexpr)
id (if idlocation (genid "send") id)
data (merge
(named-data env namelist)
(!? env {} content))]
(when idlocation (sp/update! data-model env {:ops [(ops/assign idlocation id)]}))
(sp/send! event-queue env {:send-id id
:source-session-id (env/session-id env)
:event event-name
:data data
:target (!? env target targetexpr)
:type (or (!? env type typeexpr) ::sc/chart)
:delay (or (!? env delay delayexpr) 0)})))]
(defmethod execute-element-content! :send [env element]
(log/trace "Send event" element)
(when-not (send! env element)
(raise env (evts/new-event {:name :error.execution
:data {:type :send
:element element}})))))
(defmethod execute-element-content! :cancel [{::sc/keys [event-queue] :as env}
{:keys [sendid sendidexpr] :as element}]
(log/trace "Cancel event" element)
(let [id (!? env sendid sendidexpr)]
(sp/cancel! event-queue env (env/session-id env) id)))
(>defn execute!
"Run the executable content (immediate children) of s."
[{::sc/keys [statechart] :as env} s]
[::sc/processing-env ::sc/element-or-id => nil?]
(log/trace "Execute content of" s)
(let [{:keys [children]} (chart/element statechart s)]
(doseq [n children]
(try
(let [ele (chart/element statechart n)]
(execute-element-content! env ele))
(catch #?(:clj Throwable :cljs :default) t
;; TODO: Proper error event for execution problem
(log/error t "Unexpected exception in content")))))
nil)
(>defn compute-done-data! [{::sc/keys [statechart] :as env} final-state]
[::sc/processing-env ::sc/element-or-id => any?]
(let [done-element (some->> (chart/get-children statechart final-state :done-data)
first
(chart/element statechart))]
(if done-element
(log/spy :trace "computed done data" (execute-element-content! env done-element))
{})))
(>defn enter-states!
"Enters states, triggers actions, tracks long-running invocations, and
returns updated working memory."
[{::sc/keys [statechart vwmem] :as env}]
[::sc/processing-env => nil?]
(let [[states-to-enter
;; TODO: Verify states-for-default-entry is kept around correct amount of time!
states-for-default-entry
default-history-content] (log/spy :trace "entry set"
(compute-entry-set! env))]
(doseq [s (chart/in-entry-order statechart states-to-enter)
:let [state-id (chart/element-id statechart s)]]
(log/trace "Enter" state-id)
(in-state-context env s
(vswap! vwmem update ::sc/configuration conj s)
(vswap! vwmem update ::sc/states-to-invoke conj s)
(when (and (= :late (:binding statechart)) (not (contains? (::sc/initialized-states @vwmem) state-id)))
(initialize-data-model! env s)
(vswap! vwmem update ::sc/initialized-states (fnil conj #{}) state-id))
(doseq [entry (chart/entry-handlers statechart s)]
(execute! env entry))
(when-let [t (and (contains? states-for-default-entry s)
(some->> s (chart/initial-element statechart) (chart/transition-element statechart)))]
(execute! env t))
(when-let [content (get default-history-content (chart/element-id statechart s))]
(execute-element-content! env (chart/element statechart content)))
(when (log/spy :trace (chart/final-state? statechart s))
(if (= :ROOT (chart/get-parent statechart s))
(vswap! vwmem assoc ::sc/running? false)
(let [parent (chart/get-parent statechart s)
grandparent (chart/get-parent statechart parent)
done-data (compute-done-data! env s)]
(vswap! vwmem update ::sc/internal-queue conj
(new-event {:sendid (chart/element-id statechart s)
:type :internal
:data done-data
:name (keyword (str "done.state." (name (chart/element-id statechart parent))))}))
(when (and (chart/parallel-state? statechart grandparent)
(every? (fn [s] (in-final-state? env s)) (chart/child-states statechart grandparent)))
(vswap! vwmem update ::sc/internal-queue conj
(new-event {:sendid (chart/element-id statechart s)
:type :internal
:data done-data
:name (keyword (str "done.state." (name (chart/element-id statechart grandparent))))})))))))))
(log/spy :trace "after enter states: " (::sc/configuration @vwmem))
nil)
(>defn execute-transition-content!
[{::sc/keys [vwmem] :as env}]
[::sc/processing-env => nil?]
(doseq [t (::sc/enabled-transitions @vwmem)]
(execute! env t))
nil)
(>defn compute-exit-set
[{::sc/keys [statechart vwmem] :as env} transitions]
[::sc/processing-env (s/every ::sc/element-or-id) => (s/every ::sc/id :kind set?)]
(let [states-to-exit (volatile! #{})]
(doseq [t (map #(chart/element statechart %) transitions)]
(when (contains? t :target)
(let [domain (get-transition-domain env t)]
(doseq [s (::sc/configuration @vwmem)]
(when (chart/descendant? statechart s domain)
(vswap! states-to-exit conj s))))))
@states-to-exit))
(>defn remove-conflicting-transitions
"Updates working-mem so that enabled-transitions no longer includes any conflicting ones."
[{::sc/keys [statechart] :as env} enabled-transitions]
[::sc/processing-env (s/every ::sc/id) => (s/every ::sc/id)]
(let [filtered-transitions (volatile! #{})]
(doseq [t1 enabled-transitions
:let [to-remove (volatile! #{})
preempted? (volatile! false)]]
(doseq [t2 @filtered-transitions
:while (not @preempted?)]
(when (seq (set/intersection
(compute-exit-set env [t1])
(compute-exit-set env [t2])))
(if (chart/descendant? statechart (chart/source t1) (chart/source t2))
(vswap! to-remove conj t2)
(vreset! preempted? true))))
(when (not @preempted?)
(do
(doseq [t3 @to-remove]
(vswap! filtered-transitions disj t3))
(vswap! filtered-transitions conj t1))))
@filtered-transitions))
(>defn select-transitions* [machine configuration predicate]
[::sc/statechart ::sc/configuration ifn? => ::sc/enabled-transitions]
(let [enabled-transitions (volatile! #{})
looping? (volatile! true)
start-loop! #(vreset! looping? true)
break! #(vreset! looping? false)
atomic-states (chart/in-document-order machine (filterv #(chart/atomic-state? machine %) configuration))]
(doseq [state atomic-states]
(start-loop!)
(doseq [s (into [state] (chart/get-proper-ancestors machine state))
:when @looping?]
(doseq [t (map #(chart/element machine %) (chart/in-document-order machine (chart/transitions machine s)))
:when (and @looping? (predicate t))]
(vswap! enabled-transitions conj (chart/element-id machine t))
(break!))))
@enabled-transitions))
(>defn select-eventless-transitions!
"Returns a new version of working memory with ::sc/enabled-transitions populated."
[{::sc/keys [statechart vwmem] :as env}]
[::sc/processing-env => nil?]
(let [tns (remove-conflicting-transitions env
(select-transitions* statechart (::sc/configuration @vwmem)
(fn [t] (and (not (:event t)) (condition-match env t)))))]
(vswap! vwmem assoc ::sc/enabled-transitions tns))
nil)
(>defn select-transitions!
"Returns a new version of working memory with ::sc/enabled-transitions populated."
[{::sc/keys [statechart vwmem] :as env} event]
[::sc/processing-env ::sc/event-or-name => ::sc/working-memory]
(let [tns (log/spy :trace "enabled transitions" (remove-conflicting-transitions env
(select-transitions* statechart (::sc/configuration @vwmem)
(fn [t] (and
(contains? t :event)
(evts/name-match? (:event t) event)
(condition-match env t))))))]
(vswap! vwmem assoc ::sc/enabled-transitions tns)))
(defn- invocation-details
[{::sc/keys [statechart
invocation-processors] :as env} invocation]
(let [{:keys [type typeexpr] :as invocation} (chart/element statechart invocation)
type (!? env type typeexpr)]
(assoc invocation
:type type
:processor (first (filter #(sp/supports-invocation-type? % type) invocation-processors)))))
(letfn [(start-invocation!
[{::sc/keys [statechart
data-model
execution-model
event-queue] :as env} invocation]
(let [{:keys [type src
id idlocation
namelist params
processor] :as invocation} (invocation-details env invocation)
parent-state-id (chart/nearest-ancestor-state statechart invocation)]
(if processor
(let [param-map (reduce-kv
(fn [acc k expr]
(assoc acc k (sp/run-expression! execution-model env expr)))
{}
params)
invokeid (if idlocation
(str parent-state-id "." (new-uuid))
id)
params (merge
(named-data env namelist)
param-map)]
(when (log/spy :info idlocation)
(sp/update! data-model env {:ops [(ops/assign idlocation invokeid)]}))
(sp/start-invocation! processor env {:invokeid invokeid
:src src
:type type
:params params}))
(do
(log/error "Cannot start invocation. No processor for " invocation)
;; Switch to internal event queue of working memory?
(sp/send! event-queue env {:event :error.execution
:data {:invocation-type type
:reason "Not found"}
:send-id :invocation-failure
:source-session-id (session-id env)
:target (session-id env)})))))]
(>defn run-invocations! [{::sc/keys [statechart vwmem] :as env}]
[::sc/processing-env => nil?]
(let [{::sc/keys [states-to-invoke]} @vwmem]
(doseq [state-to-invoke (chart/in-entry-order statechart states-to-invoke)]
(in-state-context env state-to-invoke
(doseq [i (chart/in-document-order statechart (chart/invocations statechart state-to-invoke))]
(start-invocation! env i))))
;; Clear states to invoke
(vswap! vwmem assoc ::sc/states-to-invoke #{}))
nil))
(>defn run-many!
"Run the code associated with the given nodes. Does NOT set context id of the nodes run."
[{::sc/keys [statechart] :as env} nodes]
[::sc/processing-env (s/every ::sc/element-or-id) => nil?]
(doseq [n nodes]
(try
(execute-element-content! env (chart/element statechart n))
(catch #?(:clj Throwable :cljs :default) e
(raise env (evts/new-event {:name :error.execution
:data {:node n
:exception e}}))
(log/error e "Unexpected execution error"))))
nil)
(letfn [(stop-invocation!
[{::sc/keys [data-model] :as env} invocation]
(let [{:keys [type
processor
id idlocation]} (invocation-details env invocation)]
(when processor
(let [invokeid (if idlocation
(sp/get-at data-model env idlocation)
id)]
(log/trace "Stopping invocation" invokeid)
(sp/stop-invocation! processor env {:invokeid invokeid
:type type})))))]
(>defn cancel-active-invocations!
[{::sc/keys [statechart] :as env} state]
[::sc/processing-env ::sc/element-or-id => nil?]
(log/spy :trace "Stopping invocations for " state)
(doseq [i (chart/invocations statechart state)]
(stop-invocation! env i))
nil))
(>defn exit-states!
"Does all of the processing for exiting states. Returns new working memory."
[{::sc/keys [statechart vwmem] :as env}]
[::sc/processing-env => nil?]
(let [{::sc/keys [enabled-transitions
states-to-invoke
configuration]} @vwmem
states-to-exit (chart/in-exit-order statechart (compute-exit-set env enabled-transitions))
states-to-invoke (set/difference states-to-invoke (set states-to-exit))]
(vswap! vwmem assoc ::sc/states-to-invoke states-to-invoke)
(doseq [s states-to-exit]
(doseq [{:keys [id type] :as h} (chart/history-elements statechart s)]
(let [f (if (= :deep type)
(fn [s0] (and
(chart/atomic-state? statechart s0)
(chart/descendant? statechart s0 s)))
(fn [s0]
(= s (chart/element-id statechart (chart/get-parent statechart s0)))))]
(vswap! vwmem assoc-in [::sc/history-value id] (into #{} (filter f configuration))))))
(doseq [s states-to-exit]
(in-state-context env s
(let [to-exit (chart/exit-handlers statechart s)]
(run-many! env to-exit)
(cancel-active-invocations! env s)
(vswap! vwmem update ::sc/configuration disj s)))))
nil)
(>defn microstep!
[env]
[::sc/processing-env => nil?]
(exit-states! env)
(execute-transition-content! env)
(enter-states! env)
nil)
(>defn handle-eventless-transitions!
"Work through eventless transitions, returning the updated working memory"
[{::sc/keys [vwmem] :as env}]
[::sc/processing-env => nil?]
(let [macrostep-done? (volatile! false)]
(while (and (::sc/running? @vwmem) (not @macrostep-done?))
(select-eventless-transitions! env)
(let [{::sc/keys [enabled-transitions
internal-queue]} @vwmem]
(when (empty? enabled-transitions)
(if (empty? internal-queue)
(vreset! macrostep-done? true)
(let [internal-event (first internal-queue)]
(log/spy :trace internal-event)
(vswap! vwmem update ::sc/internal-queue pop)
(env/assign! env [:ROOT :_event] internal-event)
(select-transitions! env internal-event))))
(when (seq (::sc/enabled-transitions @vwmem))
(microstep! env)))))
nil)
(>defn run-exit-handlers!
"Run the exit handlers of `state`."
[{::sc/keys [statechart] :as env} state]
[::sc/processing-env ::sc/element-or-id => nil?]
(in-state-context env state
(let [nodes (chart/in-document-order statechart (chart/exit-handlers statechart state))]
(run-many! env nodes)))
nil)
(>defn send-done-event! [env state]
[::sc/processing-env ::sc/element-or-id => nil?]
(in-state-context env state
(let [{:org.w3.scxml.event/keys [invokeid]
::sc/keys [parent-session-id event-queue]} env]
(when (and invokeid parent-session-id)
(let [session-id (env/session-id env)]
(log/trace "Sending done event from" session-id "to" parent-session-id "for" invokeid)
(sp/send! event-queue env {:target parent-session-id
:sendid session-id
:source-session-id session-id
:event (keyword (str "done.invoke." invokeid))})))))
nil)
(>defn exit-interpreter!
[{::sc/keys [statechart vwmem] :as env}]
[::sc/processing-env => nil?]
(let [states-to-exit (chart/in-exit-order statechart (::sc/configuration @vwmem))]
(doseq [state states-to-exit]
(run-exit-handlers! env state)
(cancel-active-invocations! env state)
(vswap! vwmem update ::sc/configuration disj state)
(when (and (chart/final-state? statechart state) (= :ROOT (chart/get-parent statechart state)))
(send-done-event! env state)))))
(>defn before-event!
"Steps that are run before processing the next event."
[{::sc/keys [statechart vwmem] :as env}]
[::sc/processing-env => nil?]
(let [{::sc/keys [running?]} @vwmem]
(when running?
(loop []
(vswap! vwmem assoc ::sc/enabled-transitions #{} ::sc/macrostep-done? false)
(handle-eventless-transitions! env)
(if running?
(do
(run-invocations! env)
(when (seq (::sc/internal-queue @vwmem))
(recur)))
(exit-interpreter! statechart))))))
(defn cancel? [event] (= :com.fulcrologic.statecharts.events/cancel (:name event)))
(defn finalize!
"Run the finalize executable content for an event from an external invocation."
[{::sc/keys [statechart] :as env} invocation event]
(let [parent (or
(chart/nearest-ancestor-state statechart invocation)
statechart)]
(in-state-context env parent
(env/assign! env [:ROOT :_event] event)
(when-let [finalize (log/spy :info "finalizers" (chart/get-children statechart invocation :finalize))]
(doseq [f finalize]
(execute! (assoc env :_event event) f)))
(env/delete! env [:ROOT :_event]))))
(letfn [(forward-event!
[{::sc/keys [data-model] :as env} invocation event]
(let [{:keys [type
processor
id idlocation]} (invocation-details env invocation)]
(when processor
(let [invokeid (if idlocation (sp/get-at data-model env idlocation) id)]
(sp/forward-event! processor env {:invokeid invokeid
:type type
:event event})))))]
(>defn handle-external-invocations! [{::sc/keys [statechart vwmem data-model] :as env}
{:keys [invokeid] :as external-event}]
[::sc/processing-env ::sc/event => nil?]
(doseq [s (::sc/configuration @vwmem)]
(doseq [{:keys [id idlocation id-location auto-forward? autoforward] :as inv} (map (partial chart/element statechart) (chart/invocations statechart s))
:let [id (if-let [loc (or idlocation id-location)]
(sp/get-at data-model env loc)
id)]]
(when (log/spy :trace "event from invocation?" (= invokeid id))
(finalize! env inv external-event))
(when (or (true? autoforward) (true? auto-forward?))
(forward-event! env inv external-event))))
nil))
(>defn processing-env
"Set up `env` to track live data that is needed during the algorithm."
[{::sc/keys [statechart-registry] :as env} statechart-src {:sc/keys [session-id
parent-session-id]
:org.w3.scxml.event/keys [invokeid] :as wmem}]
[::sc/env ::sc/statechart-src (s/keys :req [::sc/session-id]
:opt [::sc/parent-session-id
:org.w3.scxml.event/invokeid]) => ::sc/processing-env]
(if-let [statechart (sp/get-statechart statechart-registry statechart-src)]
(do
(log/spy :trace "Processing event on statechart" statechart-src)
(assoc env
::sc/context-element-id :ROOT
::sc/statechart statechart
::sc/vwmem (volatile! (merge
{::sc/session-id (or session-id (genid "session"))
::sc/statechart-src statechart-src
::sc/configuration #{} ; active states
::sc/initialized-states #{} ; states that have been entered (initialized data model) before
::sc/history-value {}
::sc/running? true}
wmem))))
(throw (ex-info "Statechart not found" {:src statechart-src}))))
(>defn process-event!
"Process the given `external-event` given a state `machine` with the `working-memory` as its current status/state.
Returns the new version of working memory which you should save to pass into the next call. Typically this function
is called by an overall processing system instead of directly."
[env external-event]
[::sc/processing-env ::sc/event-or-name => ::sc/working-memory]
(log/spy :trace external-event)
(let [event (new-event external-event)]
(with-processing-context env
(if (cancel? event)
(exit-interpreter! env)
(do
(select-transitions! env event)
(env/assign! env [:ROOT :_event] event)
(handle-external-invocations! env event)
(microstep! env)
(before-event! env)))))
(env/assign! env [:ROOT :_event] nil)
(some-> env ::sc/vwmem deref))
(>defn initialize!
"Initializes the state machine and creates an initial working memory for a new machine env.
Auto-assigns a unique UUID for session ID.
This function processes the initial transition and returns the updated working memory from `env`."
[{::sc/keys [statechart data-model parent-session-id vwmem] :as env}
{::sc/keys [invocation-data statechart-src]
:org.w3.scxml.event/keys [invokeid]}]
[::sc/processing-env (s/keys :opt [::sc/invocation-data
:org.w3.scxml.event/invokeid]) => ::sc/working-memory]
(let [{:keys [binding script]} statechart
early? (not= binding :late)
t (some->> statechart
(chart/initial-element statechart)
(chart/transition-element statechart)
(chart/element-id statechart))]
(vswap! vwmem (fn [wm]
(cond-> (assoc wm
::sc/statechart-src statechart-src
::sc/enabled-transitions (if t #{t} #{}))
parent-session-id (assoc ::sc/parent-session-id parent-session-id)
invokeid (assoc :org.w3.scxml.event/invokeid invokeid))))
(with-processing-context env
(when early?
(let [all-data-model-nodes (filter #(= :data-model (:node-type %)) (vals (::sc/elements-by-id statechart)))]
(doseq [n all-data-model-nodes]
(in-state-context env n
(initialize-data-model! env (chart/get-parent statechart n))))))
(when (map? invocation-data)
(sp/update! data-model env {:ops (ops/set-map-ops invocation-data)}))
(enter-states! env)
(before-event! env)
(when script
(execute! env script)))
@vwmem))
(defn configuration-problems
"Returns a list of problems with the current machine's working-memory configuration (active states), if there are
any."
[machine working-memory]
(let [configuration (::sc/configuration working-memory)
top-states (set (chart/child-states machine machine))
active-top-states (set/intersection top-states configuration)
atomic-states (filter #(chart/atomic-state? machine %) configuration)
necessary-ancestors (into #{} (mapcat (fn [s] (chart/get-proper-ancestors machine s)) atomic-states))
compound-states (filter #(chart/compound-state? machine %) configuration)
broken-compound-states (set
(for [cs compound-states
:let [cs-children (set (chart/child-states machine cs))]
:when (not= 1 (count (set/intersection configuration cs-children)))]
cs))
active-parallel-states (set (filter #(chart/parallel-state? machine %) configuration))
broken-parallel-states (for [cs active-parallel-states
:let [cs-children (set (chart/child-states machine cs))]
:when (not= cs-children (set/intersection configuration cs-children))]
cs)]
(cond-> []
(not= 1 (count active-top-states)) (conj "The number of top-level active states != 1")
(zero? (count atomic-states)) (conj "There are zero active atomic states")
(not= (set/intersection configuration necessary-ancestors) necessary-ancestors) (conj (str "Some active states are missing their necessary ancestors "
necessary-ancestors " should all be in " configuration))
(seq broken-compound-states) (conj (str "The compound states " broken-compound-states " should have exactly one child active (each) in " configuration))
(seq broken-parallel-states) (conj (str "The parallel states " broken-parallel-states " should have all of their children in " configuration)))))