package algaeff

  1. Overview
  2. Docs

Source file UniqueID.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
module type Param =
sig
  type elt
end

module type S =
sig
  include Param

  module ID :
  sig
    type t = private int
    val equal : t -> t -> bool
    val compare : t -> t -> int
    val dump : Format.formatter -> t -> unit
    val unsafe_of_int : int -> t
  end
  type id = ID.t

  val register : elt -> id
  val retrieve : id -> elt
  val export : unit -> elt Seq.t
  val run : ?init:elt Seq.t -> (unit -> 'a) -> 'a
end

module Make (P : Param) =
struct
  include P

  module ID =
  struct
    type t = int
    let equal = Int.equal
    let compare = Int.compare
    let dump = Format.pp_print_int
    let unsafe_of_int i = i
  end
  type id = int

  type _ Effect.t +=
    | Insert : elt -> id Effect.t
    | Select : id -> elt Effect.t
    | Export : elt Seq.t Effect.t

  let register x = Effect.perform (Insert x)
  let retrieve i = Effect.perform (Select i)
  let export () = Effect.perform Export

  module M = Map.Make (Int)
  module Eff = State.Make (struct type state = elt M.t end)

  let run ?(init=Seq.empty) f =
    let init = M.of_seq @@ Seq.zip (Seq.ints 0) init in
    Eff.run ~init @@ fun () ->
    let open Effect.Deep in
    try_with f ()
      { effc = fun (type a) (eff : a Effect.t) ->
            match eff with
            | Insert x -> Option.some @@ fun (k : (a, _) continuation) ->
              let st = Eff.get () in
              let next = M.cardinal st in
              Eff.set @@ M.add next x st;
              continue k next
            | Select i -> Option.some @@ fun (k : (a, _) continuation) ->
              continue k @@ M.find i @@ Eff.get ()
            | Export -> Option.some @@ fun (k : (a, _) continuation) ->
              continue k @@ Seq.map snd @@ M.to_seq @@ Eff.get ()
            | _ -> None }
end