Source file compose.ml
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
open! Core_kernel
open! Import
open Incremental.Let_syntax
open Component
module T = struct
type ('input, 'model, 'action, 'result, 'incr, 'event) unpacked +=
| C :
{ t1 : ('i1, 'm1, 'a1, 'r1, 'incr, 'event) unpacked
; model1 : 'm1 Packed.model_info
; action_type_id1 : 'a1 Type_equal.Id.t
; t2 : ('r1, 'm2, 'a2, 'r2, 'incr, 'event) unpacked
; model2 : 'm2 Packed.model_info
; action_type_id2 : 'a2 Type_equal.Id.t
}
-> ('i1, 'm1 * 'm2, ('a1, 'a2) Either.t, 'r2, 'incr, 'event) unpacked
let sexp_of_unpacked (type i m a r) (component : (i, m, a, r, _, _) unpacked) =
match component with
| C { t1; t2; _ } -> [%sexp Compose, (t1 : unpacked), (t2 : unpacked)]
| _ -> assert false
;;
let extension_constructor = [%extension_constructor C]
let eval (type i m a r incr event) : (i, m, a, r, incr, event) eval_type =
fun ~input ~old_model ~model ~inject ~action_type_id:_ ~environment ~incr_state t ->
match t with
| C { t1; t2; action_type_id1; action_type_id2; model1 = _; model2 = _ } ->
let s1 =
let inject e = inject (First e) in
let model = model >>| Tuple2.get1
and old_model = old_model >>| Option.map ~f:Tuple2.get1 in
eval_ext
t1
~input
~old_model
~model
~inject
~action_type_id:action_type_id1
~environment
~incr_state
in
let s2 =
let inject e = inject (Second e) in
let model = model >>| Tuple2.get2
and old_model = old_model >>| Option.map ~f:Tuple2.get2 in
eval_ext
t2
~input:(s1 >>| Snapshot.result)
~old_model
~model
~inject
~action_type_id:action_type_id2
~environment
~incr_state
in
let%map s1 = s1
and s2 = s2
and m1, m2 = model in
let apply_action1 = Snapshot.apply_action s1
and apply_action2 = Snapshot.apply_action s2
and result2 = Snapshot.result s2 in
let apply_action ~schedule_event action =
match action with
| First action1 -> apply_action1 action1 ~schedule_event, m2
| Second action2 -> m1, apply_action2 action2 ~schedule_event
in
Snapshot.create ~result:result2 ~apply_action
| _ -> assert false
;;
let compose
Packed.(T { unpacked = t1; action_type_id = action_type_id1; model = model1 })
Packed.(T { unpacked = t2; action_type_id = action_type_id2; model = model2 })
=
let action_type_id =
Type_equal.Id.create
~name:
(sprintf
"(%s, %s) Either.t"
(Type_equal.Id.name action_type_id1)
(Type_equal.Id.name action_type_id2))
(Either.sexp_of_t
(Type_equal.Id.to_sexp action_type_id1)
(Type_equal.Id.to_sexp action_type_id2))
in
let model = Packed.both_model_infos model1 model2 in
Packed.T
{ unpacked = C { t1; t2; action_type_id1; action_type_id2; model1; model2 }
; action_type_id
; model
}
;;
let visit (Packed.T { unpacked; action_type_id = _; model = _ }) visitor =
match unpacked with
| C { t1; action_type_id1; t2; action_type_id2; model1; model2 } ->
let t1 =
visit_ext
(T { unpacked = t1; action_type_id = action_type_id1; model = model1 })
visitor
in
let t2 =
visit_ext
(T { unpacked = t2; action_type_id = action_type_id2; model = model2 })
visitor
in
visitor.visit (compose t1 t2)
| _ -> assert false
;;
end
include T
let () = Component.define (module T)