env refactoring: move EnvLazy to utils/misc.ml
Gabriel Scherer
parent
6c5ddd3686
commit
dcc8a366aa
|
|
@ -68,95 +68,6 @@ exception Error of error
|
|||
|
||||
let error err = raise (Error err)
|
||||
|
||||
module EnvLazy : sig
|
||||
type ('a,'b) t
|
||||
|
||||
type log
|
||||
|
||||
val force : ('a -> 'b) -> ('a,'b) t -> 'b
|
||||
val create : 'a -> ('a,'b) t
|
||||
val get_arg : ('a,'b) t -> 'a option
|
||||
val create_forced : 'b -> ('a, 'b) t
|
||||
val create_failed : exn -> ('a, 'b) t
|
||||
|
||||
(* [force_logged log f t] is equivalent to [force f t] but if [f] returns
|
||||
[None] then [t] is recorded in [log]. [backtrack log] will then reset all
|
||||
the recorded [t]s back to their original state. *)
|
||||
val log : unit -> log
|
||||
val force_logged : log -> ('a -> 'b option) -> ('a,'b option) t -> 'b option
|
||||
val backtrack : log -> unit
|
||||
|
||||
end = struct
|
||||
|
||||
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 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
|
||||
| None ->
|
||||
x := Done None;
|
||||
log := Cons(x, e, !log);
|
||||
None
|
||||
| Some _ as y ->
|
||||
x := Done y;
|
||||
y
|
||||
| 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
|
||||
|
||||
end
|
||||
|
||||
(** Map indexed by the name of module components. *)
|
||||
module NameMap = String.Map
|
||||
|
||||
|
|
|
|||
|
|
@ -881,8 +881,80 @@ let print_if ppf flag printer arg =
|
|||
if !flag then Format.fprintf ppf "%a@." printer arg;
|
||||
arg
|
||||
|
||||
|
||||
type filepath = string
|
||||
type modname = string
|
||||
type crcs = (modname * Digest.t option) list
|
||||
|
||||
type alerts = string Stdlib.String.Map.t
|
||||
|
||||
|
||||
module EnvLazy = struct
|
||||
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 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
|
||||
| None ->
|
||||
x := Done None;
|
||||
log := Cons(x, e, !log);
|
||||
None
|
||||
| Some _ as y ->
|
||||
x := Done y;
|
||||
y
|
||||
| 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
|
||||
|
||||
end
|
||||
|
|
|
|||
|
|
@ -453,8 +453,30 @@ val print_if :
|
|||
Format.formatter -> bool ref -> (Format.formatter -> 'a -> unit) -> 'a -> 'a
|
||||
(** [print_if ppf flag fmt x] prints [x] with [fmt] on [ppf] if [b] is true. *)
|
||||
|
||||
|
||||
type filepath = string
|
||||
type modname = string
|
||||
type crcs = (modname * Digest.t option) list
|
||||
|
||||
type alerts = string Stdlib.String.Map.t
|
||||
|
||||
|
||||
module EnvLazy: sig
|
||||
type ('a,'b) t
|
||||
|
||||
type log
|
||||
|
||||
val force : ('a -> 'b) -> ('a,'b) t -> 'b
|
||||
val create : 'a -> ('a,'b) t
|
||||
val get_arg : ('a,'b) t -> 'a option
|
||||
val create_forced : 'b -> ('a, 'b) t
|
||||
val create_failed : exn -> ('a, 'b) t
|
||||
|
||||
(* [force_logged log f t] is equivalent to [force f t] but if [f] returns
|
||||
[None] then [t] is recorded in [log]. [backtrack log] will then reset all
|
||||
the recorded [t]s back to their original state. *)
|
||||
val log : unit -> log
|
||||
val force_logged : log -> ('a -> 'b option) -> ('a,'b option) t -> 'b option
|
||||
val backtrack : log -> unit
|
||||
|
||||
end
|
||||
|
|
|
|||
Loading…
Reference in New Issue