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
|
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Fabrice Le Fessant, INRIA Saclay *)
(* *)
(* Copyright 2012 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
type ('a,'b) t = ('a,'b) eval ref
and ('a,'b) eval =
| Done of 'b
| Raise of exn
| Thunk of 'a
type undo =
| Nil
| Cons : ('a, 'b) t * 'a * undo -> undo
type log = undo ref
let force f x =
match !x with
| Done x -> x
| Raise e -> raise e
| Thunk e ->
match f e with
| y ->
x := Done y;
y
| exception e ->
x := Raise e;
raise e
let get_arg x =
match !x with Thunk a -> Some a | _ -> None
let get_contents x =
match !x with
| Thunk a -> Either.Left a
| Done b -> Either.Right b
| Raise e -> raise e
let create x =
ref (Thunk x)
let create_forced y =
ref (Done y)
let create_failed e =
ref (Raise e)
let log () =
ref Nil
let force_logged log f x =
match !x with
| Done x -> x
| Raise e -> raise e
| Thunk e ->
match f e with
| (Error _ as err : _ result) ->
x := Done err;
log := Cons(x, e, !log);
err
| Ok _ as res ->
x := Done res;
res
| exception e ->
x := Raise e;
raise e
let backtrack log =
let rec loop = function
| Nil -> ()
| Cons(x, e, rest) ->
x := Thunk e;
loop rest
in
loop !log
|
