package hardcaml_step_testbench

  1. Overview
  2. Docs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file step_monad.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
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
open! Base
include Step_monad_intf
module M = M

module Make (Input_monad : Monad.S) = struct
  module Input_monad = Input_monad
  module Component = Component.Make (Input_monad)

  module Component_finished = struct
    type ('a, 'o) t =
      { output : 'o
      ; result : 'a
      }
    [@@deriving sexp_of]
  end

  module Event : sig
    type 'a t [@@deriving sexp_of]

    val create : unit -> 'a t
    val set_value : 'a t -> 'a -> unit
    val value : 'a t -> 'a option
  end = struct
    type 'a t = { mutable value : 'a option } [@@deriving fields ~getters, sexp_of]

    let create () = { value = None }

    let set_value t a =
      if Option.is_some t.value
      then
        raise_s [%message "[Event.set_value] of event whose value has already been set"];
      t.value <- Some a
    ;;
  end

  module Computation = struct
    type ('a, 'i, 'o) t =
      | Bind : ('a, 'i, 'o) t * ('a -> ('b, 'i, 'o) t) -> ('b, 'i, 'o) t
      | Current_input : ('i, 'i, 'o) t
      | Next_step : Source_code_position.t * 'o -> ('i, 'i, 'o) t
      | Return : 'a -> ('a, _, _) t
      | Thunk : (unit -> ('a, 'i, 'o) t) -> ('a, 'i, 'o) t
      | Spawn :
          { child : (('i_c, 'o_c) Component.t[@sexp.opaque])
          ; child_finished : (_, 'o_c) Component_finished.t Event.t
          ; child_input : parent:'i -> 'i_c
          ; include_child_output : parent:'o -> child:'o_c -> 'o
          }
          -> (unit, 'i, 'o) t
    [@@deriving sexp_of]

    let return x = Return x
    let bind t ~f = Bind (t, f)
    let map = `Define_using_bind
  end

  include Computation
  include Monad.Make3 (Computation)
  open! Let_syntax

  let current_input = Current_input
  let thunk f = Thunk f
  let next_step here o = Next_step (here, o)

  let output_forever output =
    let rec loop () =
      let%bind _ = next_step [%here] output in
      loop ()
    in
    loop ()
  ;;

  let wait_for (event : _ Event.t) ~output =
    let rec loop () =
      (* We use [thunk] to delay checking [Event.value] until the last possible moment,
         when the computation is being evaluated. This can avoid an unnecessary
         [next_step]. *)
      thunk (fun () ->
        match Event.value event with
        | Some a -> return a
        | None ->
          let%bind _ = next_step [%here] output in
          loop ())
    in
    loop ()
  ;;

  let wait ~output ~until =
    let rec loop input =
      if until input
      then return ()
      else (
        let%bind input = next_step [%here] output in
        loop input)
    in
    let%bind input = current_input in
    loop input
  ;;

  let for_ from_ to_ f =
    let rec loop i =
      if i > to_
      then return ()
      else (
        let%bind () = f i in
        loop (i + 1))
    in
    loop from_
  ;;

  let delay output ~num_steps =
    if num_steps < 0
    then
      raise_s
        [%message "[Step_monad.delay] got negative [num_steps]" ~_:(num_steps : int)];
    let rec loop num_steps =
      if num_steps = 0
      then return ()
      else (
        let%bind _ = next_step [%here] output in
        loop (num_steps - 1))
    in
    loop num_steps
  ;;

  let repeat ~count f =
    if count < 0
    then raise_s [%message "[Step_monad.repeat] got negative [count]" ~_:(count : int)];
    let rec loop count =
      if count = 0
      then return ()
      else (
        let%bind () = f () in
        loop (count - 1))
    in
    loop count
  ;;

  (* A [Runner.t] is a stateful value that can run a [t] one step at a time, and has
     an interface like [Component.S]. *)
  module Runner = struct
    (* An [('a, 'i, 'o) Continuation.t] is a computation awaiting a value of type ['a].
       It is analogous to a call stack. *)
    module Continuation = struct
      type ('a, 'i, 'o) t =
        | Bind : ('a -> ('b, 'i, 'o) Computation.t) * ('b, 'i, 'o) t -> ('a, 'i, 'o) t
        | Empty : ('o, 'i, 'o) t
      [@@deriving sexp_of]
    end

    (* An [('i, 'o) State.t] is the current state of a running computation, analogous to a
       program counter. *)
    module State = struct
      type ('i, 'o) t =
        | Finished of 'o
        | Running of ('i, 'i, 'o) Continuation.t
        | Unstarted of ('i -> ('o, 'i, 'o) Computation.t)
      [@@deriving sexp_of]
    end

    (* An [('i, 'o) Child.t] is a child component of a parent computation, along with
       information for translating between the parent's ['i] and ['o] and the child's
       ['i_c] and ['o_c]. *)
    module Child = struct
      type ('i, 'o) t =
        | T :
            { component : ('i_c, 'o_c) Component.t
            ; child_finished : (_, 'o_c) Component_finished.t Event.t
            ; child_input : parent:'i -> 'i_c
            ; include_child_output : parent:'o -> child:'o_c -> 'o
            }
            -> ('i, 'o) t

      let sexp_of_t _ _ (T t) = [%sexp (t.component : (_, _) Component.t)]

      let create ~child_finished ~child_input ~component ~include_child_output =
        T { component; child_finished; child_input; include_child_output }
      ;;
    end

    type ('i, 'o) t =
      { mutable state : ('i, 'o) State.t
      ; mutable children : ('i, 'o) Child.t list
      ; mutable output : 'o
      }
    [@@deriving sexp_of]

    let create ~start ~output = { state = Unstarted start; children = []; output }

    (* Each component tracks all of their children even if they are "finished". To improve
       performance we periodically traverse through the tree of children to prune the ones
       that are finished. *)
    let prune_children (type i o) (t : (i, o) t) =
      t.children
        <- List.filter t.children ~f:(fun (Child.T child) ->
             Component.prune_children child.component;
             Component.has_children child.component
             || Option.is_none (Event.value child.child_finished))
    ;;

    let update_state
      (type i o)
      ?(prune = false)
      ~update_children_after_finish
      (t : (i, o) t)
      (current_input : i)
      =
      let rec step
        : type a.
          (a, i, o) Computation.t -> (a, i, o) Continuation.t -> o * (i, o) State.t
        =
        fun computation continuation ->
        match computation with
        | Bind (computation, f) -> step computation (Bind (f, continuation))
        | Current_input -> continue continuation current_input
        | Next_step (_, output) -> output, Running continuation
        | Return a -> continue continuation a
        | Thunk f -> step (f ()) continuation
        | Spawn { child; child_finished; child_input; include_child_output } ->
          t.children
            <- Child.create
                 ~child_finished
                 ~child_input
                 ~component:child
                 ~include_child_output
               :: t.children;
          continue continuation ()
      and continue : type a. (a, i, o) Continuation.t -> a -> o * (i, o) State.t =
        fun continuation a ->
        let module C = Continuation in
        match continuation with
        | C.Empty -> a, Finished a
        | C.Bind (f, c) -> step (f a) c
      in
      let output, state =
        match t.state with
        | Finished output -> output, t.state
        | Running continuation -> continue continuation current_input
        | Unstarted start -> step (start current_input) Empty
      in
      if prune then prune_children t;
      t.state <- state;
      t.output
        <- List.fold t.children ~init:output ~f:(fun output (Child.T child) ->
             if Option.is_some (Event.value child.child_finished)
                && not update_children_after_finish
             then output
             else (
               let child_input = child.child_input ~parent:current_input in
               Component.update_state child.component child_input;
               let child_output = Component.output child.component child_input in
               child.include_child_output ~parent:output ~child:child_output))
    ;;
  end

  let create_component
    (type a i o)
    ~created_at
    ~update_children_after_finish
    ~(start : i -> ((a, o) Component_finished.t, i, o) t)
    ~(input : i Data.t)
    ~(output : o Data.t)
    : (i, o) Component.t * (a, o) Component_finished.t Event.t
    =
    let component_finished = Event.create () in
    let component =
      Component.create
        (module struct
          module Input = (val input)
          module Output = (val output)

          let created_at = created_at

          type t = (Input.t, Output.t) Runner.t [@@deriving sexp_of]

          let t =
            Runner.create ~output:Output.undefined ~start:(fun i ->
              let%bind x = start i in
              Event.set_value component_finished x;
              return x.output)
          ;;

          let output (t : t) _ = t.output

          let update_state ?prune =
            Runner.update_state ?prune ~update_children_after_finish
          ;;

          let prune_children = Runner.prune_children
          let has_children (t : t) = not (List.is_empty t.children)
        end)
    in
    component, component_finished
  ;;

  let spawn
    ?(update_children_after_finish = false)
    created_at
    ~start
    ~input
    ~output
    ~child_input
    ~include_child_output
    =
    thunk (fun () ->
      let child, child_finished =
        create_component ~update_children_after_finish ~created_at ~start ~input ~output
      in
      let%bind () = Spawn { child; child_finished; child_input; include_child_output } in
      return child_finished)
  ;;
end
OCaml

Innovation. Community. Security.