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
open Signatures
open Combinators
open Util
type 'v t = [`Empty of ('v ok -> unit) list | 'v ok] ref
let create x = ref @@ `Ok x
let empty = `Empty []
let wait xMV =
suspend @@ fun resume ->
match !xMV with
| `Ok _ as ok ->
xMV := empty;
resume ok
| `Empty rs -> xMV := `Empty ((resume :> _ ok -> _) :: rs)
let take xMV =
eta'0 @@ fun () ->
match !xMV with
| `Ok x ->
xMV := empty;
pure x
| `Empty _ -> wait xMV
let fill xMV x =
let ok = `Ok x in
match !xMV with
| `Empty [] -> xMV := ok
| `Empty (resume :: rs) ->
xMV := `Empty rs;
resume ok
| `Ok _ -> failwith "Mut.fill"
let read xMV =
eta'0 @@ fun () ->
match !xMV with
| `Ok x -> pure x
| `Empty _ ->
let+ x = wait xMV in
fill xMV x;
x
let mutate fn xMV = map (fn >>> fill xMV) (take xMV)
let modify xya xMV =
let+ x = take xMV in
let x, a = xya x in
fill xMV x;
a
let try_mutate xxE xMV =
let* x = take xMV in
eta'1 xxE x
|> tryin
(fun e ->
fill xMV x;
fail e)
(fun x ->
fill xMV x;
pure ())
let try_modify xxaE xMV =
let* x = take xMV in
eta'1 xxaE x
|> tryin
(fun e ->
fill xMV x;
fail e)
(fun (x, a) ->
fill xMV x;
pure a)
module Syntax = struct
let read p = get p >>= read
let mutate p xx = get p >>= mutate xx
let modify p xxa = get p >>= modify xxa
let try_mutate p xxE = get p >>= try_mutate xxE
let try_modify p xxaE = get p >>= try_modify xxaE
let cloning p xE = read p >>= fun v -> setting p (create v) xE
end