split Logging.Tag out and add documentation
This commit is contained in:
James Deikun
parent
d7a6973335
commit
0bbc18c23b
@ -7,166 +7,6 @@
|
|||||||
(* *)
|
(* *)
|
||||||
(**************************************************************************)
|
(**************************************************************************)
|
||||||
|
|
||||||
module Tag = struct
|
|
||||||
|
|
||||||
type _ selector = ..
|
|
||||||
|
|
||||||
module type DEF_ARG = sig
|
|
||||||
val name : string
|
|
||||||
type t
|
|
||||||
val doc : string
|
|
||||||
val pp : Format.formatter -> t -> unit
|
|
||||||
end
|
|
||||||
|
|
||||||
module type DEF = sig
|
|
||||||
include DEF_ARG
|
|
||||||
|
|
||||||
type id
|
|
||||||
val id: id
|
|
||||||
type _ selector += Me : t selector
|
|
||||||
|
|
||||||
val uid : int
|
|
||||||
|
|
||||||
end
|
|
||||||
|
|
||||||
module Def (X : DEF_ARG): DEF with type t = X.t = struct
|
|
||||||
include X
|
|
||||||
|
|
||||||
type id = Id
|
|
||||||
let id = Id
|
|
||||||
type _ selector += Me : t selector
|
|
||||||
|
|
||||||
let uid = Obj.(extension_id @@ extension_constructor @@ Me)
|
|
||||||
|
|
||||||
end
|
|
||||||
|
|
||||||
type 'a def = (module DEF with type t = 'a)
|
|
||||||
|
|
||||||
let def (type a) ?(doc = "undocumented") name pp =
|
|
||||||
(module Def(struct let name = name type t = a let doc = doc let pp = pp end): DEF with type t = a)
|
|
||||||
|
|
||||||
type (_,_) eq = Refl : ('a,'a) eq
|
|
||||||
|
|
||||||
let maybe_eq : type a b. a def -> b def -> (a,b) eq option =
|
|
||||||
fun s t ->
|
|
||||||
let module S = (val s) in
|
|
||||||
let module T = (val t) in
|
|
||||||
match S.Me with
|
|
||||||
| T.Me -> Some Refl
|
|
||||||
| _ -> None
|
|
||||||
|
|
||||||
let selector_of : type a. a def -> a selector = fun d -> let module D = (val d) in D.Me
|
|
||||||
let name : type a. a def -> string = fun d -> let module D = (val d) in D.name
|
|
||||||
let doc : type a. a def -> string = fun d -> let module D = (val d) in D.doc
|
|
||||||
let printer : type a. a def -> Format.formatter -> a -> unit = fun d -> let module D = (val d) in D.pp
|
|
||||||
let pp_def ppf d = Format.fprintf ppf "tag:%s" (name d)
|
|
||||||
|
|
||||||
module Key = struct
|
|
||||||
type t = V : 'a def -> t
|
|
||||||
type s = S : 'a selector -> s
|
|
||||||
let compare (V k0) (V k1) = compare (S (selector_of k0)) (S (selector_of k1))
|
|
||||||
end
|
|
||||||
|
|
||||||
module TagSet = Map.Make(Key)
|
|
||||||
|
|
||||||
type t = V : 'a def * 'a -> t
|
|
||||||
type binding = t
|
|
||||||
type set = binding TagSet.t
|
|
||||||
|
|
||||||
let pp ppf (V (tag, v)) =
|
|
||||||
Format.fprintf ppf "@[<1>(%a@ @[%a@])@]" pp_def tag (printer tag) v
|
|
||||||
|
|
||||||
let option_map f = function
|
|
||||||
| None -> None
|
|
||||||
| Some v -> Some (f v)
|
|
||||||
|
|
||||||
let option_bind f = function
|
|
||||||
| None -> None
|
|
||||||
| Some v -> f v
|
|
||||||
|
|
||||||
let reveal2 : type a b. a def -> b def -> b -> a option = fun t u v ->
|
|
||||||
match maybe_eq t u with
|
|
||||||
| None -> None
|
|
||||||
| Some Refl -> Some v
|
|
||||||
|
|
||||||
let reveal : 'a. 'a def -> binding -> 'a option = fun tag -> function
|
|
||||||
| V (another, v) -> reveal2 tag another v
|
|
||||||
|
|
||||||
let unveil : 'a. 'a def -> binding option -> 'a option = fun tag -> option_bind @@ reveal tag
|
|
||||||
|
|
||||||
let conceal : 'a. 'a def -> 'a -> binding = fun tag v -> V (tag, v)
|
|
||||||
|
|
||||||
let veil : 'a. 'a def -> 'a option -> binding option = fun tag -> option_map @@ conceal tag
|
|
||||||
|
|
||||||
let empty = TagSet.empty
|
|
||||||
let is_empty = TagSet.is_empty
|
|
||||||
let mem tag = TagSet.mem (Key.V tag)
|
|
||||||
let add tag v = TagSet.add (Key.V tag) (V (tag, v))
|
|
||||||
let update tag f = TagSet.update (Key.V tag) (fun b -> veil tag @@ f @@ unveil tag b)
|
|
||||||
let singleton tag v = TagSet.singleton (Key.V tag) (V (tag, v))
|
|
||||||
let remove tag = TagSet.remove (Key.V tag)
|
|
||||||
let rem = remove
|
|
||||||
type merger = { merger : 'a. 'a def -> 'a option -> 'a option -> 'a option }
|
|
||||||
let merge f = TagSet.merge @@ function
|
|
||||||
| Key.V tag -> fun a b -> veil tag @@ f.merger tag (unveil tag a) (unveil tag b)
|
|
||||||
type unioner = { unioner : 'a . 'a def -> 'a -> 'a -> 'a }
|
|
||||||
let union f = merge { merger = fun tag a b ->
|
|
||||||
match (a,b) with
|
|
||||||
| (Some aa, Some bb) -> Some (f.unioner tag aa bb)
|
|
||||||
| (Some _, None) -> a
|
|
||||||
| (None, _) -> b
|
|
||||||
}
|
|
||||||
(* no compare and equal, compare especially makes little sense *)
|
|
||||||
let iter f = TagSet.iter (fun _ -> f)
|
|
||||||
let fold f = TagSet.fold (fun _ -> f)
|
|
||||||
let for_all p = TagSet.for_all (fun _ -> p)
|
|
||||||
let exists p = TagSet.exists (fun _ -> p)
|
|
||||||
let filter p = TagSet.filter (fun _ -> p)
|
|
||||||
let partition p = TagSet.partition (fun _ -> p)
|
|
||||||
let cardinal = TagSet.cardinal
|
|
||||||
let bindings s = List.map snd @@ TagSet.bindings s
|
|
||||||
let min_binding s = snd @@ TagSet.min_binding s
|
|
||||||
let min_binding_opt s = option_map snd @@ TagSet.min_binding_opt s
|
|
||||||
let max_binding s = snd @@ TagSet.max_binding s
|
|
||||||
let max_binding_opt s = option_map snd @@ TagSet.max_binding_opt s
|
|
||||||
let choose s = snd @@ TagSet.choose s
|
|
||||||
let choose_opt s = option_map snd @@ TagSet.choose_opt s
|
|
||||||
let split tag s = (fun (l,m,r) -> (l,unveil tag m,r)) @@ TagSet.split (Key.V tag) s
|
|
||||||
(* XXX find should be different from find_opt but Logs has find_opt called find *)
|
|
||||||
let find tag s = option_bind (reveal tag) @@ TagSet.find_opt (Key.V tag) s
|
|
||||||
let find_opt tag s = option_bind (reveal tag) @@ TagSet.find_opt (Key.V tag) s
|
|
||||||
let get tag s = find_opt tag s |> function
|
|
||||||
| None -> invalid_arg (Format.asprintf "tag named %s not found in set" (name tag))
|
|
||||||
| Some v -> v
|
|
||||||
let find_first p s = snd @@ TagSet.find_first p s
|
|
||||||
let find_first_opt p s = option_map snd @@ TagSet.find_first_opt p s
|
|
||||||
let find_last p s = snd @@ TagSet.find_last p s
|
|
||||||
let find_last_opt p s = option_map snd @@ TagSet.find_last_opt p s
|
|
||||||
let map = TagSet.map
|
|
||||||
let mapi = TagSet.map
|
|
||||||
let pp_set ppf s = Format.(
|
|
||||||
fprintf ppf "@[<1>{";
|
|
||||||
pp_print_list pp ppf (bindings s);
|
|
||||||
Format.fprintf ppf "}@]")
|
|
||||||
|
|
||||||
module DSL = struct
|
|
||||||
type (_,_,_,_) arg = | A : ('x def * 'x) -> (('b -> 'x -> 'c) -> 'x -> 'd, 'b, 'c, 'd) arg
|
|
||||||
| S : ('x def * 'x) -> ('x -> 'd, 'b, 'c, 'd) arg
|
|
||||||
| T : ('x def * 'x) -> ('d, 'b, 'c, 'd) arg
|
|
||||||
let a tag v = A (tag,v)
|
|
||||||
let s tag v = S (tag,v)
|
|
||||||
let t tag v = T (tag,v)
|
|
||||||
|
|
||||||
let pp_of_def (type a) tag = let module Tg = (val tag : DEF with type t = a) in Tg.pp
|
|
||||||
|
|
||||||
let (-%): type a d. (?tags:set -> a) -> (a,Format.formatter,unit,d) arg -> (?tags:set -> d) = fun f -> function
|
|
||||||
| A (tag,v) -> (fun ?(tags=empty) -> f ~tags:(add tag v tags) (pp_of_def tag) v) [@warning "-16"]
|
|
||||||
| S (tag,v) -> (fun ?(tags=empty) -> f ~tags:(add tag v tags) v) [@warning "-16"]
|
|
||||||
| T (tag,v) -> (fun ?(tags=empty) -> f ~tags:(add tag v tags)) [@warning "-16"]
|
|
||||||
end
|
|
||||||
|
|
||||||
end
|
|
||||||
|
|
||||||
type ('a, 'b) msgf =
|
type ('a, 'b) msgf =
|
||||||
(('a, Format.formatter, unit, 'b) format4 -> ?tags:Tag.set -> 'a) -> ?tags:Tag.set -> 'b
|
(('a, Format.formatter, unit, 'b) format4 -> ?tags:Tag.set -> 'a) -> ?tags:Tag.set -> 'b
|
||||||
|
|
||||||
|
|||||||
@ -7,70 +7,6 @@
|
|||||||
(* *)
|
(* *)
|
||||||
(**************************************************************************)
|
(**************************************************************************)
|
||||||
|
|
||||||
module Tag : sig
|
|
||||||
type _ def
|
|
||||||
|
|
||||||
val def : ?doc:string -> string -> (Format.formatter -> 'a -> unit) -> 'a def
|
|
||||||
|
|
||||||
val name : 'a def -> string
|
|
||||||
val doc : 'a def -> string
|
|
||||||
val printer : 'a def -> (Format.formatter -> 'a -> unit)
|
|
||||||
val pp_def : Format.formatter -> 'a def -> unit
|
|
||||||
|
|
||||||
type t = V : 'a def * 'a -> t
|
|
||||||
val pp : Format.formatter -> t -> unit
|
|
||||||
|
|
||||||
module Key : sig
|
|
||||||
type t = V : 'a def -> t
|
|
||||||
end
|
|
||||||
type set
|
|
||||||
|
|
||||||
val empty : set
|
|
||||||
val is_empty : set -> bool
|
|
||||||
val mem : 'a def -> set -> bool
|
|
||||||
val add : 'a def -> 'a -> set -> set
|
|
||||||
val update : 'a def -> ('a option -> 'a option) -> (set -> set)
|
|
||||||
val singleton : 'a def -> 'a -> set
|
|
||||||
val remove : 'a def -> set -> set
|
|
||||||
val rem : 'a def -> set -> set
|
|
||||||
type merger = { merger : 'a. 'a def -> 'a option -> 'a option -> 'a option }
|
|
||||||
val merge : merger -> set -> set -> set
|
|
||||||
type unioner = { unioner : 'a. 'a def -> 'a -> 'a -> 'a }
|
|
||||||
val union : unioner -> set -> set -> set
|
|
||||||
val iter : (t -> unit) -> set -> unit
|
|
||||||
val fold : (t -> 'b -> 'b) -> (set -> 'b -> 'b)
|
|
||||||
val for_all : (t -> bool) -> (set -> bool)
|
|
||||||
val exists : (t -> bool) -> (set -> bool)
|
|
||||||
val filter : (t -> bool) -> set -> set
|
|
||||||
val partition : (t -> bool) -> set -> (set * set)
|
|
||||||
val cardinal : set -> int
|
|
||||||
val min_binding : set -> t
|
|
||||||
val min_binding_opt : set -> t option
|
|
||||||
val max_binding : set -> t
|
|
||||||
val max_binding_opt : set -> t option
|
|
||||||
val choose : set -> t
|
|
||||||
val choose_opt : set -> t option
|
|
||||||
val split : 'a def -> set -> set * 'a option * set
|
|
||||||
val find : 'a def -> set -> 'a option
|
|
||||||
val get : 'a def -> set -> 'a
|
|
||||||
val find_first : (Key.t -> bool) -> set -> t
|
|
||||||
val find_first_opt : (Key.t -> bool) -> set -> t option
|
|
||||||
val find_last : (Key.t -> bool) -> set -> t
|
|
||||||
val find_last_opt : (Key.t -> bool) -> set -> t option
|
|
||||||
val map : (t -> t) -> set -> set
|
|
||||||
val mapi : (t -> t) -> set -> set
|
|
||||||
val pp_set : Format.formatter -> set -> unit
|
|
||||||
|
|
||||||
module DSL : sig
|
|
||||||
type (_,_,_,_) arg
|
|
||||||
val a : 'v def -> 'v -> (('b -> 'v -> 'c) -> 'v -> 'd, 'b, 'c, 'd) arg
|
|
||||||
val s : 'v def -> 'v -> ('v -> 'd, 'b, 'c, 'd) arg
|
|
||||||
val t : 'v def -> 'v -> ('d, 'b, 'c, 'd) arg
|
|
||||||
val (-%) : (?tags:set -> 'a) -> ('a,Format.formatter,unit,'d) arg -> (?tags:set -> 'd)
|
|
||||||
end
|
|
||||||
|
|
||||||
end
|
|
||||||
|
|
||||||
type log_section = private ..
|
type log_section = private ..
|
||||||
|
|
||||||
type log_message = {
|
type log_message = {
|
||||||
|
|||||||
164
src/lib_stdlib/tag.ml
Normal file
164
src/lib_stdlib/tag.ml
Normal file
@ -0,0 +1,164 @@
|
|||||||
|
(**************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* Copyright (c) 2014 - 2018. *)
|
||||||
|
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||||
|
(* *)
|
||||||
|
(* All rights reserved. No warranty, explicit or implicit, provided. *)
|
||||||
|
(* *)
|
||||||
|
(**************************************************************************)
|
||||||
|
|
||||||
|
type _ selector = ..
|
||||||
|
|
||||||
|
module type DEF_ARG = sig
|
||||||
|
val name : string
|
||||||
|
type t
|
||||||
|
val doc : string
|
||||||
|
val pp : Format.formatter -> t -> unit
|
||||||
|
end
|
||||||
|
|
||||||
|
module type DEF = sig
|
||||||
|
include DEF_ARG
|
||||||
|
|
||||||
|
type id
|
||||||
|
val id: id
|
||||||
|
type _ selector += Me : t selector
|
||||||
|
|
||||||
|
val uid : int
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
module Def (X : DEF_ARG): DEF with type t = X.t = struct
|
||||||
|
include X
|
||||||
|
|
||||||
|
type id = Id
|
||||||
|
let id = Id
|
||||||
|
type _ selector += Me : t selector
|
||||||
|
|
||||||
|
let uid = Obj.(extension_id @@ extension_constructor @@ Me)
|
||||||
|
|
||||||
|
end
|
||||||
|
|
||||||
|
type 'a def = (module DEF with type t = 'a)
|
||||||
|
|
||||||
|
let def (type a) ?(doc = "undocumented") name pp =
|
||||||
|
(module Def(struct let name = name type t = a let doc = doc let pp = pp end): DEF with type t = a)
|
||||||
|
|
||||||
|
type (_,_) eq = Refl : ('a,'a) eq
|
||||||
|
|
||||||
|
let maybe_eq : type a b. a def -> b def -> (a,b) eq option =
|
||||||
|
fun s t ->
|
||||||
|
let module S = (val s) in
|
||||||
|
let module T = (val t) in
|
||||||
|
match S.Me with
|
||||||
|
| T.Me -> Some Refl
|
||||||
|
| _ -> None
|
||||||
|
|
||||||
|
let selector_of : type a. a def -> a selector = fun d -> let module D = (val d) in D.Me
|
||||||
|
let name : type a. a def -> string = fun d -> let module D = (val d) in D.name
|
||||||
|
let doc : type a. a def -> string = fun d -> let module D = (val d) in D.doc
|
||||||
|
let printer : type a. a def -> Format.formatter -> a -> unit = fun d -> let module D = (val d) in D.pp
|
||||||
|
let pp_def ppf d = Format.fprintf ppf "tag:%s" (name d)
|
||||||
|
|
||||||
|
module Key = struct
|
||||||
|
type t = V : 'a def -> t
|
||||||
|
type s = S : 'a selector -> s
|
||||||
|
let compare (V k0) (V k1) = compare (S (selector_of k0)) (S (selector_of k1))
|
||||||
|
end
|
||||||
|
|
||||||
|
module TagSet = Map.Make(Key)
|
||||||
|
|
||||||
|
type t = V : 'a def * 'a -> t
|
||||||
|
type binding = t
|
||||||
|
type set = binding TagSet.t
|
||||||
|
|
||||||
|
let pp ppf (V (tag, v)) =
|
||||||
|
Format.fprintf ppf "@[<1>(%a@ @[%a@])@]" pp_def tag (printer tag) v
|
||||||
|
|
||||||
|
let option_map f = function
|
||||||
|
| None -> None
|
||||||
|
| Some v -> Some (f v)
|
||||||
|
|
||||||
|
let option_bind f = function
|
||||||
|
| None -> None
|
||||||
|
| Some v -> f v
|
||||||
|
|
||||||
|
let reveal2 : type a b. a def -> b def -> b -> a option = fun t u v ->
|
||||||
|
match maybe_eq t u with
|
||||||
|
| None -> None
|
||||||
|
| Some Refl -> Some v
|
||||||
|
|
||||||
|
let reveal : 'a. 'a def -> binding -> 'a option = fun tag -> function
|
||||||
|
| V (another, v) -> reveal2 tag another v
|
||||||
|
|
||||||
|
let unveil : 'a. 'a def -> binding option -> 'a option = fun tag -> option_bind @@ reveal tag
|
||||||
|
|
||||||
|
let conceal : 'a. 'a def -> 'a -> binding = fun tag v -> V (tag, v)
|
||||||
|
|
||||||
|
let veil : 'a. 'a def -> 'a option -> binding option = fun tag -> option_map @@ conceal tag
|
||||||
|
|
||||||
|
let empty = TagSet.empty
|
||||||
|
let is_empty = TagSet.is_empty
|
||||||
|
let mem tag = TagSet.mem (Key.V tag)
|
||||||
|
let add tag v = TagSet.add (Key.V tag) (V (tag, v))
|
||||||
|
let update tag f = TagSet.update (Key.V tag) (fun b -> veil tag @@ f @@ unveil tag b)
|
||||||
|
let singleton tag v = TagSet.singleton (Key.V tag) (V (tag, v))
|
||||||
|
let remove tag = TagSet.remove (Key.V tag)
|
||||||
|
let rem = remove
|
||||||
|
type merger = { merger : 'a. 'a def -> 'a option -> 'a option -> 'a option }
|
||||||
|
let merge f = TagSet.merge @@ function
|
||||||
|
| Key.V tag -> fun a b -> veil tag @@ f.merger tag (unveil tag a) (unveil tag b)
|
||||||
|
type unioner = { unioner : 'a . 'a def -> 'a -> 'a -> 'a }
|
||||||
|
let union f = merge { merger = fun tag a b ->
|
||||||
|
match (a,b) with
|
||||||
|
| (Some aa, Some bb) -> Some (f.unioner tag aa bb)
|
||||||
|
| (Some _, None) -> a
|
||||||
|
| (None, _) -> b
|
||||||
|
}
|
||||||
|
(* no compare and equal, compare especially makes little sense *)
|
||||||
|
let iter f = TagSet.iter (fun _ -> f)
|
||||||
|
let fold f = TagSet.fold (fun _ -> f)
|
||||||
|
let for_all p = TagSet.for_all (fun _ -> p)
|
||||||
|
let exists p = TagSet.exists (fun _ -> p)
|
||||||
|
let filter p = TagSet.filter (fun _ -> p)
|
||||||
|
let partition p = TagSet.partition (fun _ -> p)
|
||||||
|
let cardinal = TagSet.cardinal
|
||||||
|
let bindings s = List.map snd @@ TagSet.bindings s
|
||||||
|
let min_binding s = snd @@ TagSet.min_binding s
|
||||||
|
let min_binding_opt s = option_map snd @@ TagSet.min_binding_opt s
|
||||||
|
let max_binding s = snd @@ TagSet.max_binding s
|
||||||
|
let max_binding_opt s = option_map snd @@ TagSet.max_binding_opt s
|
||||||
|
let choose s = snd @@ TagSet.choose s
|
||||||
|
let choose_opt s = option_map snd @@ TagSet.choose_opt s
|
||||||
|
let split tag s = (fun (l,m,r) -> (l,unveil tag m,r)) @@ TagSet.split (Key.V tag) s
|
||||||
|
(* XXX find should be different from find_opt but Logs has find_opt called find *)
|
||||||
|
let find tag s = option_bind (reveal tag) @@ TagSet.find_opt (Key.V tag) s
|
||||||
|
let find_opt tag s = option_bind (reveal tag) @@ TagSet.find_opt (Key.V tag) s
|
||||||
|
let get tag s = find_opt tag s |> function
|
||||||
|
| None -> invalid_arg (Format.asprintf "tag named %s not found in set" (name tag))
|
||||||
|
| Some v -> v
|
||||||
|
let find_first p s = snd @@ TagSet.find_first p s
|
||||||
|
let find_first_opt p s = option_map snd @@ TagSet.find_first_opt p s
|
||||||
|
let find_last p s = snd @@ TagSet.find_last p s
|
||||||
|
let find_last_opt p s = option_map snd @@ TagSet.find_last_opt p s
|
||||||
|
let map = TagSet.map
|
||||||
|
let mapi = TagSet.map
|
||||||
|
let pp_set ppf s = Format.(
|
||||||
|
fprintf ppf "@[<1>{";
|
||||||
|
pp_print_list pp ppf (bindings s);
|
||||||
|
Format.fprintf ppf "}@]")
|
||||||
|
|
||||||
|
module DSL = struct
|
||||||
|
type (_,_,_,_) arg = | A : ('x def * 'x) -> (('b -> 'x -> 'c) -> 'x -> 'd, 'b, 'c, 'd) arg
|
||||||
|
| S : ('x def * 'x) -> ('x -> 'd, 'b, 'c, 'd) arg
|
||||||
|
| T : ('x def * 'x) -> ('d, 'b, 'c, 'd) arg
|
||||||
|
let a tag v = A (tag,v)
|
||||||
|
let s tag v = S (tag,v)
|
||||||
|
let t tag v = T (tag,v)
|
||||||
|
|
||||||
|
let pp_of_def (type a) tag = let module Tg = (val tag : DEF with type t = a) in Tg.pp
|
||||||
|
|
||||||
|
let (-%): type a d. (?tags:set -> a) -> (a,Format.formatter,unit,d) arg -> (?tags:set -> d) = fun f -> function
|
||||||
|
| A (tag,v) -> (fun ?(tags=empty) -> f ~tags:(add tag v tags) (pp_of_def tag) v) [@warning "-16"]
|
||||||
|
| S (tag,v) -> (fun ?(tags=empty) -> f ~tags:(add tag v tags) v) [@warning "-16"]
|
||||||
|
| T (tag,v) -> (fun ?(tags=empty) -> f ~tags:(add tag v tags)) [@warning "-16"]
|
||||||
|
end
|
||||||
96
src/lib_stdlib/tag.mli
Normal file
96
src/lib_stdlib/tag.mli
Normal file
@ -0,0 +1,96 @@
|
|||||||
|
(**************************************************************************)
|
||||||
|
(* *)
|
||||||
|
(* Copyright (c) 2014 - 2018. *)
|
||||||
|
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||||
|
(* *)
|
||||||
|
(* All rights reserved. No warranty, explicit or implicit, provided. *)
|
||||||
|
(* *)
|
||||||
|
(**************************************************************************)
|
||||||
|
|
||||||
|
(** Tags and tag sets. Tags are basically similar to a plain extensible
|
||||||
|
variant type, but wrapped with metadata that enables them to be printed
|
||||||
|
generically and combined into tag sets where each tag is either not
|
||||||
|
present or associated with a specific value.
|
||||||
|
|
||||||
|
They are primarily intended for use with the `Logging` module but it
|
||||||
|
would probably be reasonable to use them for other purposes. *)
|
||||||
|
|
||||||
|
(** Type of tag definitions. Analogous to a constructor of an extensible
|
||||||
|
variant type, but first-class. *)
|
||||||
|
type _ def
|
||||||
|
|
||||||
|
(** Define a new tag with a name, printer, and optional documentation string.
|
||||||
|
This is generative, not applicative, so tag definitions created with
|
||||||
|
identical names and printers at different times or places will be
|
||||||
|
different tags! You probably do not want to define a tag in a local
|
||||||
|
scope unless you have something really tricky in mind. Basically all
|
||||||
|
the caveats you would have if you wrote [type t +=] apply. *)
|
||||||
|
val def : ?doc:string -> string -> (Format.formatter -> 'a -> unit) -> 'a def
|
||||||
|
|
||||||
|
val name : 'a def -> string
|
||||||
|
val doc : 'a def -> string
|
||||||
|
val printer : 'a def -> (Format.formatter -> 'a -> unit)
|
||||||
|
|
||||||
|
(** Print the name of a tag definition. *)
|
||||||
|
val pp_def : Format.formatter -> 'a def -> unit
|
||||||
|
|
||||||
|
(** A binding consisting of a tag and value. If a `def` is a constructor
|
||||||
|
of an extensible variant type, a `t` is a value of that type. *)
|
||||||
|
type t = V : 'a def * 'a -> t
|
||||||
|
val pp : Format.formatter -> t -> unit
|
||||||
|
|
||||||
|
module Key : sig
|
||||||
|
type t = V : 'a def -> t
|
||||||
|
end
|
||||||
|
|
||||||
|
(** Tag sets. If `t` is an extensible variant type, `set` is a set of `t`s
|
||||||
|
no two of which have the same constructor. Most ordinary set and map
|
||||||
|
operations familiar from the Ocaml standard library are provided.
|
||||||
|
`equal` and `compare` are purposely not provided as there is no
|
||||||
|
meaningful ordering on tags and their arguments may not even have a
|
||||||
|
meaningful notion of equality. *)
|
||||||
|
type set
|
||||||
|
|
||||||
|
val empty : set
|
||||||
|
val is_empty : set -> bool
|
||||||
|
val mem : 'a def -> set -> bool
|
||||||
|
val add : 'a def -> 'a -> set -> set
|
||||||
|
val update : 'a def -> ('a option -> 'a option) -> (set -> set)
|
||||||
|
val singleton : 'a def -> 'a -> set
|
||||||
|
val remove : 'a def -> set -> set
|
||||||
|
val rem : 'a def -> set -> set
|
||||||
|
type merger = { merger : 'a. 'a def -> 'a option -> 'a option -> 'a option }
|
||||||
|
val merge : merger -> set -> set -> set
|
||||||
|
type unioner = { unioner : 'a. 'a def -> 'a -> 'a -> 'a }
|
||||||
|
val union : unioner -> set -> set -> set
|
||||||
|
val iter : (t -> unit) -> set -> unit
|
||||||
|
val fold : (t -> 'b -> 'b) -> (set -> 'b -> 'b)
|
||||||
|
val for_all : (t -> bool) -> (set -> bool)
|
||||||
|
val exists : (t -> bool) -> (set -> bool)
|
||||||
|
val filter : (t -> bool) -> set -> set
|
||||||
|
val partition : (t -> bool) -> set -> (set * set)
|
||||||
|
val cardinal : set -> int
|
||||||
|
val min_binding : set -> t
|
||||||
|
val min_binding_opt : set -> t option
|
||||||
|
val max_binding : set -> t
|
||||||
|
val max_binding_opt : set -> t option
|
||||||
|
val choose : set -> t
|
||||||
|
val choose_opt : set -> t option
|
||||||
|
val split : 'a def -> set -> set * 'a option * set
|
||||||
|
val find : 'a def -> set -> 'a option
|
||||||
|
val get : 'a def -> set -> 'a
|
||||||
|
val find_first : (Key.t -> bool) -> set -> t
|
||||||
|
val find_first_opt : (Key.t -> bool) -> set -> t option
|
||||||
|
val find_last : (Key.t -> bool) -> set -> t
|
||||||
|
val find_last_opt : (Key.t -> bool) -> set -> t option
|
||||||
|
val map : (t -> t) -> set -> set
|
||||||
|
val mapi : (t -> t) -> set -> set
|
||||||
|
val pp_set : Format.formatter -> set -> unit
|
||||||
|
|
||||||
|
module DSL : sig
|
||||||
|
type (_,_,_,_) arg
|
||||||
|
val a : 'v def -> 'v -> (('b -> 'v -> 'c) -> 'v -> 'd, 'b, 'c, 'd) arg
|
||||||
|
val s : 'v def -> 'v -> ('v -> 'd, 'b, 'c, 'd) arg
|
||||||
|
val t : 'v def -> 'v -> ('d, 'b, 'c, 'd) arg
|
||||||
|
val (-%) : (?tags:set -> 'a) -> ('a,Format.formatter,unit,'d) arg -> (?tags:set -> 'd)
|
||||||
|
end
|
||||||
Loading…
Reference in New Issue
Block a user