From 0bbc18c23b45e10c03f379964ce00639c4400c73 Mon Sep 17 00:00:00 2001 From: James Deikun Date: Thu, 28 Jun 2018 18:15:42 -0400 Subject: [PATCH] split Logging.Tag out and add documentation --- src/lib_stdlib/logging.ml | 160 ------------------------------------ src/lib_stdlib/logging.mli | 64 --------------- src/lib_stdlib/tag.ml | 164 +++++++++++++++++++++++++++++++++++++ src/lib_stdlib/tag.mli | 96 ++++++++++++++++++++++ 4 files changed, 260 insertions(+), 224 deletions(-) create mode 100644 src/lib_stdlib/tag.ml create mode 100644 src/lib_stdlib/tag.mli diff --git a/src/lib_stdlib/logging.ml b/src/lib_stdlib/logging.ml index 6b5b99726..7360afdc7 100644 --- a/src/lib_stdlib/logging.ml +++ b/src/lib_stdlib/logging.ml @@ -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 = (('a, Format.formatter, unit, 'b) format4 -> ?tags:Tag.set -> 'a) -> ?tags:Tag.set -> 'b diff --git a/src/lib_stdlib/logging.mli b/src/lib_stdlib/logging.mli index 2e48d5edc..ff1181f95 100644 --- a/src/lib_stdlib/logging.mli +++ b/src/lib_stdlib/logging.mli @@ -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_message = { diff --git a/src/lib_stdlib/tag.ml b/src/lib_stdlib/tag.ml new file mode 100644 index 000000000..c2a11195c --- /dev/null +++ b/src/lib_stdlib/tag.ml @@ -0,0 +1,164 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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 diff --git a/src/lib_stdlib/tag.mli b/src/lib_stdlib/tag.mli new file mode 100644 index 000000000..e01f4de51 --- /dev/null +++ b/src/lib_stdlib/tag.mli @@ -0,0 +1,96 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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