Source file gather_lazy.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
open! Core
open! Bonsai_private_base.Import
open! Bonsai_private_base
open Incr.Let_syntax

let f
  ~(gather : _ Computation.gather_fun)
  ~recursive_scopes
  ~time_source
  ~lazy_computation
  ~here
  =
  let wrap_lazy ~type_id inject = Action.lazy_ ~type_id >>> inject in
  let model = Meta.Model.Hidden.lazy_ in
  let gathered =
    lazy_computation
    |> Lazy.map ~f:(fun c ->
      (Timer.timer ()).time `Gather ~f:(fun () ->
        Trampoline.run (gather ~recursive_scopes ~time_source c)))
  in
  let run ~environment ~fix_envs ~path ~model ~inject =
    let (Computation.T
          { model = model_info
          ; input = input_info
          ; action = action_info
          ; run
          ; apply_action = _
          ; reset = _
          ; may_contain = _
          })
      =
      force gathered
    in
    annotate ~here Model model;
    let input_model =
      let%map model in
      let (Meta.Model.Hidden.T { model; info; _ }) =
        Option.value
          model
          ~default:(Meta.Model.Hidden.create model_info model_info.default)
      in
      let witness = Meta.Model.Type_id.same_witness_exn info.type_id model_info.type_id in
      Type_equal.conv witness model
    in
    let%bind.Trampoline snapshot, () =
      run
        ~environment
        ~fix_envs
        ~path
        ~model:input_model
        ~inject:(wrap_lazy ~type_id:action_info inject)
    in
    let input =
      Input.map (Snapshot.input snapshot) ~f:(fun input ->
        Meta.Input.Hidden.T { input; type_id = input_info; key = () })
    in
    Trampoline.return
      ( Snapshot.create
          ~here
          ~input
          ~result:(Snapshot.result snapshot)
          ~lifecycle:(Snapshot.lifecycle snapshot)
      , () )
  in
  let apply_action
    ~inject
    ~schedule_event
    input
    model
    (Action.Lazy { action; type_id = action_type_id })
    =
    (* forcing the lazy is fine because actions are finite in length *)
    let (T
          { model = model_info
          ; input = input_info
          ; action = action_info
          ; apply_action
          ; run = _
          ; reset = _
          ; may_contain = _
          })
      =
      force gathered
    in
    let (Meta.Model.Hidden.T { model = chosen_model; info = chosen_model_info; _ }) =
      Option.value model ~default:(Meta.Model.Hidden.create model_info model_info.default)
    in
    let T = Action.Type_id.same_witness_exn action_type_id action_info in
    let T =
      Meta.Model.Type_id.same_witness_exn chosen_model_info.type_id model_info.type_id
    in
    let new_model =
      match input with
      | Computation_status.Active
          (Meta.Input.Hidden.T { input; type_id = input_type_id; key = () }) ->
        let T = Meta.Input.same_witness_exn input_type_id input_info in
        apply_action
          ~inject:(wrap_lazy ~type_id:action_info inject)
          ~schedule_event
          (Active input)
          chosen_model
          action
      | Inactive ->
        apply_action
          ~inject:(wrap_lazy ~type_id:action_info inject)
          ~schedule_event
          Inactive
          chosen_model
          action
    in
    Some (Meta.Model.Hidden.create model_info new_model)
  in
  let reset' ~inject ~schedule_event model =
    let (T
          { model = model_info
          ; action = action_info
          ; reset
          ; apply_action = _
          ; run = _
          ; input = _
          ; may_contain = _
          })
      =
      force gathered
    in
    let (Meta.Model.Hidden.T { model = chosen_model; info = chosen_model_info; _ }) =
      model
    in
    let T =
      Meta.Model.Type_id.same_witness_exn chosen_model_info.type_id model_info.type_id
    in
    let new_model =
      reset ~inject:(wrap_lazy ~type_id:action_info inject) ~schedule_event chosen_model
    in
    Meta.Model.Hidden.create model_info new_model
  in
  let reset ~inject ~schedule_event model =
    (* If the model is None, then you can't descend into the reset because it will force
       the lazy, but that doesn't matter because there's nothing to reset anyway. *)
    match model with
    | None -> None
    | Some model -> Some (reset' ~inject ~schedule_event model)
  in
  Trampoline.return
    (Computation.T
       { model
       ; input = Meta.Input.Hidden.unit
       ; action = Action.Type_id.lazy_
       ; apply_action
       ; run
       ; reset
       ; may_contain = May_contain.Unresolved.lazy_
       })
;;