simon/ocaml-containers
1
0
Fork 0
mirror of https://github.com/c-cube/ocaml-containers.git synced 2025-12-07 11:45:31 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

more efficient and simple serialization, using

Browse source 
function combinators instead of a single GADT
This commit is contained in:
Simon Cruanes 2014-03-01 18:53:26 +01:00
parent 6718277501
commit d794b6f726
2 changed files with 339 additions and 345 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

301
conv.ml
View file

@ -36,6 +36,139 @@ let __error msg =
(fun b -> raise (ConversionFailure (Buffer.contents b))) (fun b -> raise (ConversionFailure (Buffer.contents b)))
b msg b msg
(* function to look up the given name in an association list *)
let _get_field l name =
try List.assoc name l
with Not_found ->
__error "record field %s not found in source" name
(** Universal sink, such as a serialization format *)
module UniversalSink = struct
type 'a t = {
unit_ : 'a;
bool_ : bool -> 'a;
float_ : float -> 'a;
int_ : int -> 'a;
string_ : string -> 'a;
list_ : 'a list -> 'a;
record : (string*'a) list -> 'a;
tuple : 'a list -> 'a;
sum : string -> 'a list -> 'a;
}
end
module Source = struct
module US = UniversalSink
type 'a t = {
convert : 'b. 'b US.t -> 'a -> 'b;
}
type 'r record_src =
| RecordField : string * ('r -> 'a) * 'a t * 'r record_src -> 'r record_src
| RecordStop : 'r record_src
type hlist =
| HNil : hlist
| HCons : 'a t * 'a * hlist -> hlist
let hnil = HNil
let hcons src x tl = HCons(src,x,tl)
let unit_ = { convert = (fun sink () -> sink.US.unit_); }
let bool_ = { convert = (fun sink b -> sink.US.bool_ b); }
let float_ = { convert = (fun sink f -> sink.US.float_ f); }
let int_ = { convert = (fun sink i -> sink.US.int_ i); }
let string_ = { convert = (fun sink s -> sink.US.string_ s); }
let list_ e =
let convert sink l =
let l' = List.map (e.convert sink) l in
sink.US.list_ l'
in {convert;}
let map f src =
{ convert=(fun sink x -> src.convert sink (f x)); }
let array_ src = map Array.to_list (list_ src)
let field name get src' cont =
RecordField (name,get,src',cont)
let record_stop = RecordStop
let record (r:'a record_src) =
(* fold over record description *)
let rec conv_fields
: type b. b US.t -> (string*b)list -> 'a record_src -> 'a -> (string*b)list
= fun sink acc r x -> match r with
| RecordStop -> acc
| RecordField (name,get,src',r') ->
let acc = (name, src'.convert sink (get x)) :: acc in
conv_fields sink acc r' x
in
let convert sink x = sink.US.record (conv_fields sink [] r x) in
{ convert; }
let record_fix f =
let rec convert: type b. b US.t -> 'r -> b
= fun sink x ->
(* evaluate src, and use it to convert x *)
(Lazy.force src).convert sink x
and src = lazy (record (f {convert})) in
Lazy.force src
(* fold over hlist *)
let rec conv_hlist : type b. b US.t -> b list -> hlist -> b list
= fun sink acc t -> match t with
| HNil -> List.rev acc
| HCons (src',x,t') ->
let acc = src'.convert sink x :: acc in
conv_hlist sink acc t'
let tuple t =
let convert sink x =
let hlist = t x in
sink.US.tuple (conv_hlist sink [] hlist) in
{ convert; }
let pair a b =
{ convert=(fun sink (x,y) ->
sink.US.tuple [a.convert sink x; b.convert sink y]);
}
let triple a b c =
{ convert=(fun sink (x,y,z) ->
sink.US.tuple [a.convert sink x; b.convert sink y; c.convert sink z]);
}
let quad a b c d =
{ convert=(fun sink (x,y,z,w) ->
sink.US.tuple [a.convert sink x; b.convert sink y;
c.convert sink z; d.convert sink w]);
}
let sum f =
let convert sink x =
let name, l = f x in
sink.US.sum name (conv_hlist sink [] l) in
{ convert; }
let sum0 f =
{convert=(fun sink x -> sink.US.sum (f x) []); }
let sum_fix f =
let rec convert : type b. b US.t -> 'r -> b
= fun sink x ->
(* evaluate src, and use it to convert x *)
(Lazy.force src).convert sink x
and src = lazy (sum (f {convert})) in
Lazy.force src
let opt src = sum (function
| Some x -> "some", hcons src x hnil
| None -> "none", hnil)
end
let into src sink x = src.Source.convert sink x
module Sink = struct module Sink = struct
(** A specific sink that requires a given shape to produce (** A specific sink that requires a given shape to produce
a value of type 'a *) a value of type 'a *)
@ -155,106 +288,9 @@ module Sink = struct
| List _ -> ExpectList | List _ -> ExpectList
| (Fix f) as sink -> expected (f sink) | (Fix f) as sink -> expected (f sink)
| Map (sink', _) -> expected sink' | Map (sink', _) -> expected sink'
(** Universal sink, such as a serialization format *)
module Universal = struct
type 'a t = {
unit_ : 'a;
bool_ : bool -> 'a;
float_ : float -> 'a;
int_ : int -> 'a;
string_ : string -> 'a;
list_ : 'a list -> 'a;
record : (string*'a) list -> 'a;
tuple : 'a list -> 'a;
sum : string -> 'a list -> 'a;
}
end
end end
module Source = struct module UniversalSource = struct
(** A specific source that follows the shape of the type 'a *)
type 'a t =
| Unit : unit t
| Bool : bool t
| Float : float t
| Int : int t
| String : string t
| List : 'a t -> 'a list t
| Record : 'a record_src -> 'a t
| Tuple : 'a tuple_src -> 'a t
| Sum : ('a -> string * sum_src) -> 'a t
| Map : 'a t * ('b -> 'a) -> 'b t
| Fix : ('a t -> 'a t) -> 'a t
and 'r record_src =
| RecordField : string * ('r -> 'a) * 'a t * 'r record_src -> 'r record_src
| RecordStop : 'r record_src
and 't tuple_src =
| TupleField : 'a t * ('t -> 'a) * 't tuple_src -> 't tuple_src
| TupleStop : 't tuple_src
and sum_src =
| SumCons : 'a t * 'a * sum_src -> sum_src
| SumNil : sum_src
let unit_ = Unit
let bool_ = Bool
let float_ = Float
let int_ = Int
let string_ = String
let list_ e = List e
let map f src = Map (src, f)
let array_ src = map Array.to_list (list_ src)
let field name get src' cont =
RecordField (name,get,src',cont)
let record_stop = RecordStop
let record r = Record r
let record_fix f =
Fix (fun r -> Record (f r))
let tuple_field src get cont = TupleField (src,get,cont)
let tuple_stop = TupleStop
let tuple t = Tuple t
let pair a b =
tuple (tuple_field a fst (tuple_field b snd tuple_stop))
let triple a b c =
tuple
(tuple_field a (fun (a,b,c) -> a)
(tuple_field b (fun (a,b,c) -> b)
(tuple_field c (fun (a,b,c) -> c)
tuple_stop)))
let quad a b c d =
tuple
(tuple_field a (fun (a,b,c,d) -> a)
(tuple_field b (fun (a,b,c,d) -> b)
(tuple_field c (fun (a,b,c,d) -> c)
(tuple_field d (fun (a,b,c,d) -> d)
tuple_stop))))
let sum_nil = SumNil
let sum_cons src' x tl = SumCons (src', x, tl)
let sum f = Sum f
let sum_fix f =
Fix (fun s -> Sum (f s))
let opt src = sum (function
| Some x -> "some", sum_cons src x sum_nil
| None -> "none", sum_nil)
(* function to look up the given name in an association list *)
let _get_field l name =
try List.assoc name l
with Not_found ->
__error "record field %s not found in source" name
module Universal = struct
type 'a t = { type 'a t = {
visit : 'b. 'b Sink.t -> 'a -> 'b; visit : 'b. 'b Sink.t -> 'a -> 'b;
} }
@ -366,53 +402,10 @@ module Source = struct
| Sink.Map (sink', f) -> f (sum ~src sink' name s) | Sink.Map (sink', f) -> f (sum ~src sink' name s)
| Sink.Fix f -> sum ~src (f sink) name s | Sink.Fix f -> sum ~src (f sink) name s
| _ -> __error "get Sum(%s), but expected %s" name (Sink.__expected sink) | _ -> __error "get Sum(%s), but expected %s" name (Sink.__expected sink)
end
end end
let rec into : type a b. a Source.t -> b Sink.Universal.t -> a -> b = let from (src:'a UniversalSource.t) (sink:'b Sink.t) (x:'a) : 'b =
let open Sink.Universal in src.UniversalSource.visit sink x
fun src sink x -> match src with
| Source.Unit -> sink.unit_
| Source.Bool -> sink.bool_ x
| Source.Float -> sink.float_ x
| Source.Int -> sink.int_ x
| Source.String -> sink.string_ x
| Source.List src' ->
let l = List.map (into src' sink) x in
sink.list_ l
| Source.Record r ->
let rec conv_fields : (string*b)list -> a Source.record_src -> b
= fun acc r -> match r with
| Source.RecordStop -> sink.record (List.rev acc)
| Source.RecordField (name,get,src',r') ->
let acc = (name, into src' sink (get x)) :: acc in
conv_fields acc r'
in conv_fields [] r
| Source.Tuple t ->
let rec conv_tuple : b list -> a Source.tuple_src -> b
= fun acc t -> match t with
| Source.TupleStop -> sink.tuple (List.rev acc)
| Source.TupleField (src',get,t') ->
let acc = into src' sink (get x) :: acc in
conv_tuple acc t'
in conv_tuple [] t
| Source.Sum f ->
let rec conv_sum : string -> b list -> Source.sum_src -> b
= fun name acc sum -> match sum with
| Source.SumNil -> sink.sum name (List.rev acc)
| Source.SumCons (src',x,sum') ->
let acc = into src' sink x :: acc in
conv_sum name acc sum'
in
let name, sum = f x in
conv_sum name [] sum
| Source.Map (src', f) -> into src' sink (f x)
| Source.Fix f ->
let src' = f src in
into src' sink x
let from (src:'a Source.Universal.t) (sink:'b Sink.t) (x:'a) : 'b =
src.Source.Universal.visit sink x
(** {6 Exemples} *) (** {6 Exemples} *)
@ -428,7 +421,7 @@ module Json = struct
] ]
let source = let source =
let module U = Source.Universal in let module U = UniversalSource in
let rec visit : type b. b Sink.t -> t -> b = let rec visit : type b. b Sink.t -> t -> b =
fun sink x -> match x with fun sink x -> match x with
| `Int i -> U.int_ sink i | `Int i -> U.int_ sink i
@ -450,8 +443,8 @@ module Json = struct
and src = { U.visit=visit; } in and src = { U.visit=visit; } in
src src
let sink : t Sink.Universal.t = let sink : t UniversalSink.t =
let open Sink.Universal in let open UniversalSink in
{ unit_ = `Null; { unit_ = `Null;
bool_ = (fun b -> `Bool b); bool_ = (fun b -> `Bool b);
float_ = (fun f -> `Float f); float_ = (fun f -> `Float f);
@ -472,7 +465,7 @@ module Sexp = struct
| List of t list | List of t list
let source = let source =
let module U = Source.Universal in let module U = UniversalSource in
let rec visit : type b. b Sink.t -> t -> b = let rec visit : type b. b Sink.t -> t -> b =
fun sink x -> match x, Sink.expected sink with fun sink x -> match x, Sink.expected sink with
| Atom s, Sink.ExpectSum -> U.sum ~src sink s [] | Atom s, Sink.ExpectSum -> U.sum ~src sink s []
@ -489,7 +482,7 @@ module Sexp = struct
src src
let sink = let sink =
let open Sink.Universal in let open UniversalSink in
{ unit_ = List []; { unit_ = List [];
bool_ = (fun b -> Atom (string_of_bool b)); bool_ = (fun b -> Atom (string_of_bool b));
float_ = (fun f -> Atom (string_of_float f)); float_ = (fun f -> Atom (string_of_float f));
@ -521,7 +514,7 @@ module Bencode = struct
| Assoc of (string * t) list | Assoc of (string * t) list
let source = let source =
let module U = Source.Universal in let module U = UniversalSource in
let rec visit : type b. b Sink.t -> t -> b = let rec visit : type b. b Sink.t -> t -> b =
fun sink x -> match x, Sink.expected sink with fun sink x -> match x, Sink.expected sink with
| String s, Sink.ExpectSum -> U.sum ~src sink s [] | String s, Sink.ExpectSum -> U.sum ~src sink s []
@ -536,7 +529,7 @@ module Bencode = struct
src src
let sink = let sink =
let open Sink.Universal in let open UniversalSink in
{ unit_ = Int 0; { unit_ = Int 0;
bool_ = (fun b -> Int (if b then 1 else 0)); bool_ = (fun b -> Int (if b then 1 else 0));
float_ = (fun f -> String (string_of_float f)); float_ = (fun f -> String (string_of_float f));
@ -571,7 +564,7 @@ module Point = struct
yield_record {x;y;color;prev} yield_record {x;y;color;prev}
)) ))
let source = let rec source =
Source.(record_fix Source.(record_fix
(fun self -> (fun self ->
field "x" (fun p -> p.x) int_ @@ field "x" (fun p -> p.x) int_ @@
@ -605,9 +598,9 @@ module Lambda = struct
let source = Source.(sum_fix let source = Source.(sum_fix
(fun self t -> match t with (fun self t -> match t with
| Var s -> "var", sum_cons string_ s @@ sum_nil | Var s -> "var", hcons string_ s @@ hnil
| App (t1, t2) -> "app", sum_cons self t1 @@ sum_cons self t2 @@ sum_nil | App (t1, t2) -> "app", hcons self t1 @@ hcons self t2 @@ hnil
| Lambda (s, t) -> "lam", sum_cons string_ s @@ sum_cons self t @@ sum_nil | Lambda (s, t) -> "lam", hcons string_ s @@ hcons self t @@ hnil
)) ))
let sink = Sink.(sum_fix let sink = Sink.(sum_fix

157
conv.mli
View file

@ -28,12 +28,73 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
exception ConversionFailure of string exception ConversionFailure of string
(** {6 Universal sink}
Some type any valye can be traducted into, such as a serialization format
like JSON or B-encode. *)
module UniversalSink : sig
type 'a t = {
unit_ : 'a;
bool_ : bool -> 'a;
float_ : float -> 'a;
int_ : int -> 'a;
string_ : string -> 'a;
list_ : 'a list -> 'a;
record : (string*'a) list -> 'a;
tuple : 'a list -> 'a;
sum : string -> 'a list -> 'a;
}
end
(** {6 Sources}
A 'a source is used to build values of some type 'b, given a 'b sink
description of how to build values of type 'b. *)
module Source : sig
type 'a t = {
convert : 'b. 'b UniversalSink.t -> 'a -> 'b;
}
type 'r record_src
type hlist =
| HNil : hlist
| HCons : 'a t * 'a * hlist -> hlist
val hnil : hlist
val hcons : 'a t -> 'a -> hlist -> hlist
val unit_ : unit t
val bool_ : bool t
val float_ : float t
val int_ : int t
val string_ : string t
val list_ : 'a t -> 'a list t
val map : ('a -> 'b) -> 'b t -> 'a t
val array_ : 'a t -> 'a array t
val field : string -> ('r -> 'a) -> 'a t -> 'r record_src -> 'r record_src
val record_stop : 'r record_src
val record : 'r record_src -> 'r t
val record_fix : ('r t -> 'r record_src) -> 'r t
val tuple : ('a -> hlist) -> 'a t
val pair : 'a t -> 'b t -> ('a * 'b) t
val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t
val sum : ('a -> string * hlist) -> 'a t
val sum0 : ('a -> string) -> 'a t
val sum_fix : ('a t -> 'a -> string * hlist) -> 'a t
val opt : 'a t -> 'a option t
end
(** {6 Sinks} (** {6 Sinks}
A sink is used to traverse values of some type 'a *) A sink is used to produce values of type 'a from a universal source. *)
module Sink : sig module Sink : sig
(** A specific sink that requires a given shape to produce type 'a t (** How to produce values of type 'a *)
a value of type 'a *)
type 'a t
and 'r record_sink = and 'r record_sink =
| RecordField : string * 'a t * ('a -> 'r record_sink) -> 'r record_sink | RecordField : string * 'a t * ('a -> 'r record_sink) -> 'r record_sink
@ -87,74 +148,15 @@ module Sink : sig
val expected : _ t -> expected val expected : _ t -> expected
(** To be used by sources that have ambiguities to know what is expected. (** To be used by sources that have ambiguities to know what is expected.
maps and fixpoints are unrolled. *) maps and fixpoints are unrolled. *)
(** Universal sink, such as a serialization format *)
module Universal : sig
type 'a t = {
unit_ : 'a;
bool_ : bool -> 'a;
float_ : float -> 'a;
int_ : int -> 'a;
string_ : string -> 'a;
list_ : 'a list -> 'a;
record : (string*'a) list -> 'a;
tuple : 'a list -> 'a;
sum : string -> 'a list -> 'a;
}
end
end end
(** {6 Sources} (** {6 Universal source}
A source is used to build values of some type 'a *)
module Source : sig
(** A specific source that follows the shape of the type 'a *)
type 'a t
and 'r record_src = source from type 'a, where 'a is typically a serialization
| RecordField : string * ('r -> 'a) * 'a t * 'r record_src -> 'r record_src format. This is used to translate from 'a to some other type.
| RecordStop : 'r record_src A universal format should use the provided combinators to
interface with {!Sink.t} values *)
and 't tuple_src = module UniversalSource : sig
| TupleField : 'a t * ('t -> 'a) * 't tuple_src -> 't tuple_src
| TupleStop : 't tuple_src
and sum_src =
| SumCons : 'a t * 'a * sum_src -> sum_src
| SumNil : sum_src
val unit_ : unit t
val bool_ : bool t
val float_ : float t
val int_ : int t
val string_ : string t
val list_ : 'a t -> 'a list t
val map : ('b -> 'a) -> 'a t -> 'b t
val array_ : 'a t -> 'a array t
val field : string -> ('r -> 'a) -> 'a t -> 'r record_src -> 'r record_src
val record_stop : 'r record_src
val record : 'r record_src -> 'r t
val record_fix : ('r t -> 'r record_src) -> 'r t
val tuple_field : 'a t -> ('t -> 'a) -> 't tuple_src -> 't tuple_src
val tuple_stop : 't tuple_src
val tuple : 't tuple_src -> 't t
val pair : 'a t -> 'b t -> ('a * 'b) t
val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t
val sum_nil : sum_src
val sum_cons : 'a t -> 'a -> sum_src -> sum_src
val sum : ('a -> string * sum_src) -> 'a t
val sum_fix : ('a t -> 'a -> string * sum_src) -> 'a t
val opt : 'a t -> 'a option t
(** Universal source from type 'a. A universal type should use
combinators to implement the visitor pattern. *)
module Universal : sig
type 'a t = { type 'a t = {
visit : 'b. 'b Sink.t -> 'a -> 'b; visit : 'b. 'b Sink.t -> 'a -> 'b;
} }
@ -168,15 +170,14 @@ module Source : sig
val record : src:'a t -> 'b Sink.t -> (string*'a) list -> 'b val record : src:'a t -> 'b Sink.t -> (string*'a) list -> 'b
val tuple : src:'a t -> 'b Sink.t -> 'a list -> 'b val tuple : src:'a t -> 'b Sink.t -> 'a list -> 'b
val sum : src:'a t -> 'b Sink.t -> string -> 'a list -> 'b val sum : src:'a t -> 'b Sink.t -> string -> 'a list -> 'b
end
end end
(** {6 Conversion Functions} *) (** {6 Conversion Functions} *)
val into : 'a Source.t -> 'b Sink.Universal.t -> 'a -> 'b val into : 'a Source.t -> 'b UniversalSink.t -> 'a -> 'b
(** Conversion to universal sink *) (** Conversion to universal sink *)
val from : 'a Source.Universal.t -> 'b Sink.t -> 'a -> 'b val from : 'a UniversalSource.t -> 'b Sink.t -> 'a -> 'b
(** Conversion from universal source *) (** Conversion from universal source *)
(* TODO for format conversion (* TODO for format conversion
@ -196,8 +197,8 @@ module Json : sig
| `Assoc of (string * t) list | `Assoc of (string * t) list
] ]
val source : t Source.Universal.t val source : t UniversalSource.t
val sink : t Sink.Universal.t val sink : t UniversalSink.t
end end
module Sexp : sig module Sexp : sig
@ -205,8 +206,8 @@ module Sexp : sig
| Atom of string | Atom of string
| List of t list | List of t list
val source : t Source.Universal.t val source : t UniversalSource.t
val sink : t Sink.Universal.t val sink : t UniversalSink.t
val fmt : Format.formatter -> t -> unit (* for debug *) val fmt : Format.formatter -> t -> unit (* for debug *)
end end
@ -217,8 +218,8 @@ module Bencode : sig
| List of t list | List of t list
| Assoc of (string * t) list | Assoc of (string * t) list
val source : t Source.Universal.t val source : t UniversalSource.t
val sink : t Sink.Universal.t val sink : t UniversalSink.t
end end
(** Tests *) (** Tests *)