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
open Picos
type 'a request = {
request : 'r. (unit -> 'r) Computation.t -> ('a -> 'r) -> unit;
}
[@@unboxed]
type 'a t =
| Request : 'a request -> 'a t
| Choose : 'a t list -> 'a t
| Wrap : { event : 'b t; fn : 'b -> 'a } -> 'a t
type ('a, 'r) id = Yes : ('a, 'a) id | No : ('a, 'r) id
let rec request_1_as :
type a r. (_ -> r) Computation.t -> (a -> r) -> (a, r) id -> a t -> _ =
fun target to_result id -> function
| Request { request } -> request target to_result
| Choose ts -> request_n_as target to_result id ts
| Wrap { event; fn } ->
let to_result =
match id with No -> fun x -> to_result (fn x) | Yes -> fn
in
request_1_as target to_result No event
and request_n_as :
type a r. (_ -> r) Computation.t -> (a -> r) -> (a, r) id -> a t list -> _ =
fun target to_result id -> function
| [] -> ()
| t :: ts ->
request_1_as target to_result id t;
request_n_as target to_result id ts
type ('a, _) tycon = Id : ('a, 'a t) tycon | List : ('a, 'a t list) tycon
let sync_as : type a n. n -> (a, n) tycon -> a =
fun t n ->
let target = Computation.create ~mode:`LIFO () in
match
match n with
| Id -> request_1_as target Fun.id Yes t
| List -> request_n_as target Fun.id Yes t
with
| () ->
if Computation.is_running target then begin
let t = Trigger.create () in
if Computation.try_attach target t then
match Trigger.await t with
| None -> ()
| Some (exn, bt) ->
if Computation.try_cancel target exn bt then
Printexc.raise_with_backtrace exn bt
end;
Computation.await target ()
| exception exn ->
let bt = Printexc.get_raw_backtrace () in
Computation.cancel target exn bt;
Printexc.raise_with_backtrace exn bt
let guard create_event =
let request target to_result =
request_1_as target to_result No (create_event ())
in
Request { request }
let[@alert "-handler"] from_computation source =
let request target to_result =
let result () = to_result (Computation.await source) in
if Computation.is_running source then begin
let propagator =
Trigger.from_action result target @@ fun _ result target ->
Computation.return target result
in
if Computation.try_attach source propagator then begin
let detacher =
Trigger.from_action propagator source @@ fun _ propagator source ->
Computation.detach source propagator
in
if not (Computation.try_attach target detacher) then
Computation.detach source propagator
end
else Computation.return target result
end
else Computation.return target result
in
Request { request }
let always value =
let request computation to_result =
Computation.return computation @@ fun () -> to_result value
in
Request { request }
type 'a event = 'a t
let[@inline] from_request p = Request p
let[@inline] choose ts = Choose ts
let[@inline] wrap event fn = Wrap { event; fn }
let[@inline] map fn event = Wrap { event; fn }
let[@inline] sync t = sync_as t Id
let[@inline] select ts = sync_as ts List