Source file gather_assoc_on.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
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
open! Core
open! Bonsai_private_base.Import
open! Bonsai_private_base
open Incr.Let_syntax
let f
(type io cmp_io model cmp_model)
~gather
~recursive_scopes
~time_source
~map
~(io_comparator : (io, cmp_io) Comparator.Module.t)
~(model_comparator : (model, cmp_model) Comparator.Module.t)
~io_key_id
~io_cmp_id
~model_key_id
~model_cmp_id
~data_id
~by
~get_model_key
~here
=
let module Model_comparator = (val model_comparator) in
let wrap_assoc_on ~io_key ~model_key inject =
Action.assoc_on ~io_key ~model_key ~io_id:io_key_id ~io_comparator >>> inject
in
let model_key_comparator = Model_comparator.comparator in
let%bind.Trampoline (Computation.T
{ model = model_info
; input = input_info
; action
; apply_action
; run
; reset
; may_contain
})
=
gather ~recursive_scopes ~time_source by
in
let run ~environment ~fix_envs ~path ~model ~inject =
let resolved = Environment.Recursive.resolve_may_contain fix_envs may_contain in
let map_input = Value.eval environment map in
let create_keyed = unstage (Path.Elem.keyed ~comparator:io_comparator io_key_id) in
let results_map, input_map, lifecycle_map =
Gather_assoc.unzip3_mapi'
map_input
~contains_lifecycle:resolved.lifecycle
~contains_input:resolved.input
~comparator:io_comparator
~f:(fun ~key:io_key ~data:value ->
let%pattern_bind results_map, input_map, lifecycle_map =
let path =
match resolved.path with
| Yes_or_maybe -> Path.append path Path.Elem.(Assoc (create_keyed io_key))
| No -> path
in
let key_incr = Incr.const io_key in
annotate ~here Assoc_key key_incr;
annotate ~here Assoc_input value;
let environment =
environment
|> Environment.add_exn ~key:io_key_id ~data:key_incr
|> Environment.add_exn ~key:data_id ~data:value
in
let model_key =
let%map value in
get_model_key io_key value
in
Incr.set_cutoff
model_key
(Incr.Cutoff.of_compare (Comparator.compare model_key_comparator));
let%bind model_key in
let model =
let%map model in
match Map.find model model_key with
| Some (_, model) -> model
| None -> model_info.default
in
annotate ~here Model model;
let snapshot, () =
run
~environment
~fix_envs
~path
~inject:(wrap_assoc_on ~io_key ~model_key inject)
~model
|> Trampoline.run
in
let%mapn result = Snapshot.result snapshot
and input = Input.to_incremental (Snapshot.input snapshot)
and lifecycle = Snapshot.lifecycle_or_empty ~here snapshot in
result, input, lifecycle
in
results_map, input_map, lifecycle_map)
in
annotate ~here Assoc_results results_map;
annotate ~here Assoc_lifecycles lifecycle_map;
let lifecycle =
match resolved.lifecycle with
| No -> None
| Yes_or_maybe ->
let unfolded =
Incr_map.unordered_fold_nested_maps
lifecycle_map
~init:Path.Map.empty
~add:(fun ~outer_key:_ ~inner_key:key ~data acc ->
Map.update acc key ~f:(function
| Some _ -> Path.raise_duplicate key
| None -> data))
~remove:(fun ~outer_key:_ ~inner_key:key ~data:_ acc -> Map.remove acc key)
in
annotate ~here Assoc_lifecycles unfolded;
Some unfolded
in
let input =
match resolved.input with
| No -> Input.static_dummy_for_assoc io_comparator
| Yes_or_maybe -> Input.dynamic input_map
in
Trampoline.return (Snapshot.create ~here ~result:results_map ~input ~lifecycle, ())
in
let apply_action
~inject
~schedule_event
input
model
(Action.Assoc_on { io_key; model_key; action; io_id = _; io_comparator = _ })
=
let input =
Computation_status.bind input ~f:(fun input ->
Map.find input io_key |> Computation_status.of_option)
in
let specific_model =
match Map.find model model_key with
| None -> model_info.default
| Some (_prev_io_key, model) -> model
in
let new_model =
apply_action
~inject:(wrap_assoc_on ~io_key ~model_key inject)
~schedule_event
input
specific_model
action
in
if model_info.equal new_model model_info.default
then Map.remove model model_key
else Map.set model ~key:model_key ~data:(io_key, new_model)
in
let reset ~inject ~schedule_event model =
Map.filter_mapi model ~f:(fun ~key:model_key ~data:(io_key, model) ->
let new_model =
reset ~inject:(wrap_assoc_on ~io_key ~model_key inject) ~schedule_event model
in
if model_info.equal new_model model_info.default
then None
else Some (io_key, new_model))
in
Trampoline.return
(Computation.T
{ model =
Meta.Model.map_on
model_comparator
io_comparator
model_key_id
io_key_id
model_cmp_id
model_info
; input = Meta.Input.map io_key_id io_cmp_id input_info
; action =
Action.Type_id.assoc_on
~io_key:io_key_id
~model_key:model_key_id
~sexp_of_model_key:(Comparator.sexp_of_t Model_comparator.comparator)
~action
; apply_action
; reset
; run
; may_contain
})
;;