mirror of
https://github.com/c-cube/ocaml-containers.git
synced 2025-12-07 03:35:30 -05:00
more efficient and simple serialization, using
function combinators instead of a single GADT
This commit is contained in:
Simon Cruanes
parent
6718277501
commit
d794b6f726
2 changed files with 339 additions and 345 deletions
503
conv.ml
503
conv.ml
|
|
@ -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,264 +288,124 @@ 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 = {
|
||||||
type 'a t =
|
visit : 'b. 'b Sink.t -> 'a -> 'b;
|
||||||
| 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 =
|
let rec unit_ : type b. b Sink.t -> b
|
||||||
| RecordField : string * ('r -> 'a) * 'a t * 'r record_src -> 'r record_src
|
= fun sink -> match sink with
|
||||||
| RecordStop : 'r record_src
|
| Sink.Unit -> ()
|
||||||
|
| Sink.Int -> 0
|
||||||
|
| Sink.Map (sink', f) -> f (unit_ sink')
|
||||||
|
| Sink.Fix f -> unit_ (f sink)
|
||||||
|
| _ -> __error "get Unit, but expected %s" (Sink.__expected sink)
|
||||||
|
|
||||||
and 't tuple_src =
|
let rec bool_ : type b. b Sink.t -> bool -> b
|
||||||
| TupleField : 'a t * ('t -> 'a) * 't tuple_src -> 't tuple_src
|
= fun sink b -> match sink with
|
||||||
| TupleStop : 't tuple_src
|
| Sink.Bool -> b
|
||||||
|
| Sink.Int -> if b then 1 else 0
|
||||||
|
| Sink.String -> string_of_bool b
|
||||||
|
| Sink.Map (sink', f) -> f (bool_ sink' b)
|
||||||
|
| Sink.Fix f -> bool_ (f sink) b
|
||||||
|
| _ -> __error "get Bool, but expected %s" (Sink.__expected sink)
|
||||||
|
|
||||||
and sum_src =
|
let rec float_ : type b. b Sink.t -> float -> b
|
||||||
| SumCons : 'a t * 'a * sum_src -> sum_src
|
= fun sink x -> match sink with
|
||||||
| SumNil : sum_src
|
| Sink.Float -> x
|
||||||
|
| Sink.String -> string_of_float x
|
||||||
|
| Sink.Map (sink', f) -> f (float_ sink' x)
|
||||||
|
| Sink.Fix f -> float_ (f sink) x
|
||||||
|
| _ -> __error "get Float, but expected %s" (Sink.__expected sink)
|
||||||
|
|
||||||
let unit_ = Unit
|
let rec int_ : type b. b Sink.t -> int -> b
|
||||||
let bool_ = Bool
|
= fun sink i -> match sink with
|
||||||
let float_ = Float
|
| Sink.Int -> i
|
||||||
let int_ = Int
|
| Sink.Bool -> i <> 0
|
||||||
let string_ = String
|
| Sink.String -> string_of_int i
|
||||||
let list_ e = List e
|
| Sink.Map (sink', f) -> f (int_ sink' i)
|
||||||
|
| Sink.Fix f -> int_ (f sink) i
|
||||||
|
| _ -> __error "get Int, but expected %s" (Sink.__expected sink)
|
||||||
|
|
||||||
let map f src = Map (src, f)
|
let rec string_ : type b. b Sink.t -> string -> b
|
||||||
let array_ src = map Array.to_list (list_ src)
|
= fun sink s -> match sink with
|
||||||
|
| Sink.String -> s
|
||||||
|
| Sink.Int ->
|
||||||
|
begin try int_of_string s
|
||||||
|
with Invalid_argument _ -> __error "get String, but expected Int"
|
||||||
|
end
|
||||||
|
| Sink.Bool ->
|
||||||
|
begin try bool_of_string s
|
||||||
|
with Invalid_argument _ -> __error "get String, but expected Bool"
|
||||||
|
end
|
||||||
|
| Sink.Float ->
|
||||||
|
begin try float_of_string s
|
||||||
|
with Invalid_argument _ -> __error "get String, but expected Float"
|
||||||
|
end
|
||||||
|
| Sink.Map (sink', f) -> f (string_ sink' s)
|
||||||
|
| Sink.Fix f -> string_ (f sink) s
|
||||||
|
| _ -> __error "get String, but expected %s" (Sink.__expected sink)
|
||||||
|
|
||||||
let field name get src' cont =
|
let rec list_ : type b. src:'a t -> b Sink.t -> 'a list -> b
|
||||||
RecordField (name,get,src',cont)
|
= fun ~src sink l -> match sink with
|
||||||
let record_stop = RecordStop
|
| Sink.List f ->
|
||||||
let record r = Record r
|
f (fun sink' -> List.map (src.visit sink') l)
|
||||||
let record_fix f =
|
| Sink.Tuple _ -> tuple ~src sink l
|
||||||
Fix (fun r -> Record (f r))
|
| Sink.Map (sink', f) -> f (list_ ~src sink' l)
|
||||||
|
| Sink.Fix f -> list_ ~src (f sink) l
|
||||||
|
| _ -> __error "get List, but expected %s" (Sink.__expected sink)
|
||||||
|
|
||||||
let tuple_field src get cont = TupleField (src,get,cont)
|
and record : type b. src:'a t -> b Sink.t -> (string*'a) list -> b
|
||||||
let tuple_stop = TupleStop
|
= fun ~src sink l -> match sink with
|
||||||
let tuple t = Tuple t
|
| Sink.Record r ->
|
||||||
|
(* fold over the expected record fields *)
|
||||||
|
let rec build_record
|
||||||
|
= function
|
||||||
|
| Sink.RecordStop x -> x
|
||||||
|
| Sink.RecordField (name, sink', cont) ->
|
||||||
|
let src_field = _get_field l name in
|
||||||
|
let sink_field = src.visit sink' src_field in
|
||||||
|
build_record (cont sink_field)
|
||||||
|
in build_record r
|
||||||
|
| Sink.Map (sink', f) -> f (record ~src sink' l)
|
||||||
|
| Sink.Fix f -> record ~src (f sink) l
|
||||||
|
| _ -> __error "get Record, but expected %s" (Sink.__expected sink)
|
||||||
|
|
||||||
let pair a b =
|
and build_hlist : 't. src:'a t -> 'a list -> 't Sink.hlist -> 't
|
||||||
tuple (tuple_field a fst (tuple_field b snd tuple_stop))
|
= fun ~src l t_sink -> match l, t_sink with
|
||||||
|
| [], Sink.HNil t -> t
|
||||||
|
| [], _ ->
|
||||||
|
__error "not enough tuple components"
|
||||||
|
| _::_, Sink.HNil _ ->
|
||||||
|
__error "too many tuple components (%d too many)" (List.length l)
|
||||||
|
| x::l', Sink.HCons (sink', cont) ->
|
||||||
|
let y = src.visit sink' x in
|
||||||
|
build_hlist ~src l' (cont y)
|
||||||
|
|
||||||
let triple a b c =
|
and tuple : type b. src:'a t -> b Sink.t -> 'a list -> b
|
||||||
tuple
|
= fun ~src sink l -> match sink with
|
||||||
(tuple_field a (fun (a,b,c) -> a)
|
| Sink.Tuple t_sink ->
|
||||||
(tuple_field b (fun (a,b,c) -> b)
|
(* fold over the expected tuple component *)
|
||||||
(tuple_field c (fun (a,b,c) -> c)
|
build_hlist ~src l t_sink
|
||||||
tuple_stop)))
|
| Sink.List _ -> list_ ~src sink l (* adapt *)
|
||||||
|
| Sink.Map (sink', f) -> f (tuple ~src sink' l)
|
||||||
|
| Sink.Fix f -> tuple ~src (f sink) l
|
||||||
|
| _ -> __error "get Tuple, but expected %s" (Sink.__expected sink)
|
||||||
|
|
||||||
let quad a b c d =
|
and sum : type b. src:'a t -> b Sink.t -> string -> 'a list -> b
|
||||||
tuple
|
= fun ~src sink name s -> match sink with
|
||||||
(tuple_field a (fun (a,b,c,d) -> a)
|
| Sink.Sum f ->
|
||||||
(tuple_field b (fun (a,b,c,d) -> b)
|
let l_sink = f name in
|
||||||
(tuple_field c (fun (a,b,c,d) -> c)
|
build_hlist ~src s l_sink
|
||||||
(tuple_field d (fun (a,b,c,d) -> d)
|
| Sink.Map (sink', f) -> f (sum ~src sink' name s)
|
||||||
tuple_stop))))
|
| Sink.Fix f -> sum ~src (f sink) name s
|
||||||
|
| _ -> __error "get Sum(%s), but expected %s" name (Sink.__expected sink)
|
||||||
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 = {
|
|
||||||
visit : 'b. 'b Sink.t -> 'a -> 'b;
|
|
||||||
}
|
|
||||||
|
|
||||||
let rec unit_ : type b. b Sink.t -> b
|
|
||||||
= fun sink -> match sink with
|
|
||||||
| Sink.Unit -> ()
|
|
||||||
| Sink.Int -> 0
|
|
||||||
| Sink.Map (sink', f) -> f (unit_ sink')
|
|
||||||
| Sink.Fix f -> unit_ (f sink)
|
|
||||||
| _ -> __error "get Unit, but expected %s" (Sink.__expected sink)
|
|
||||||
|
|
||||||
let rec bool_ : type b. b Sink.t -> bool -> b
|
|
||||||
= fun sink b -> match sink with
|
|
||||||
| Sink.Bool -> b
|
|
||||||
| Sink.Int -> if b then 1 else 0
|
|
||||||
| Sink.String -> string_of_bool b
|
|
||||||
| Sink.Map (sink', f) -> f (bool_ sink' b)
|
|
||||||
| Sink.Fix f -> bool_ (f sink) b
|
|
||||||
| _ -> __error "get Bool, but expected %s" (Sink.__expected sink)
|
|
||||||
|
|
||||||
let rec float_ : type b. b Sink.t -> float -> b
|
|
||||||
= fun sink x -> match sink with
|
|
||||||
| Sink.Float -> x
|
|
||||||
| Sink.String -> string_of_float x
|
|
||||||
| Sink.Map (sink', f) -> f (float_ sink' x)
|
|
||||||
| Sink.Fix f -> float_ (f sink) x
|
|
||||||
| _ -> __error "get Float, but expected %s" (Sink.__expected sink)
|
|
||||||
|
|
||||||
let rec int_ : type b. b Sink.t -> int -> b
|
|
||||||
= fun sink i -> match sink with
|
|
||||||
| Sink.Int -> i
|
|
||||||
| Sink.Bool -> i <> 0
|
|
||||||
| Sink.String -> string_of_int i
|
|
||||||
| Sink.Map (sink', f) -> f (int_ sink' i)
|
|
||||||
| Sink.Fix f -> int_ (f sink) i
|
|
||||||
| _ -> __error "get Int, but expected %s" (Sink.__expected sink)
|
|
||||||
|
|
||||||
let rec string_ : type b. b Sink.t -> string -> b
|
|
||||||
= fun sink s -> match sink with
|
|
||||||
| Sink.String -> s
|
|
||||||
| Sink.Int ->
|
|
||||||
begin try int_of_string s
|
|
||||||
with Invalid_argument _ -> __error "get String, but expected Int"
|
|
||||||
end
|
|
||||||
| Sink.Bool ->
|
|
||||||
begin try bool_of_string s
|
|
||||||
with Invalid_argument _ -> __error "get String, but expected Bool"
|
|
||||||
end
|
|
||||||
| Sink.Float ->
|
|
||||||
begin try float_of_string s
|
|
||||||
with Invalid_argument _ -> __error "get String, but expected Float"
|
|
||||||
end
|
|
||||||
| Sink.Map (sink', f) -> f (string_ sink' s)
|
|
||||||
| Sink.Fix f -> string_ (f sink) s
|
|
||||||
| _ -> __error "get String, but expected %s" (Sink.__expected sink)
|
|
||||||
|
|
||||||
let rec list_ : type b. src:'a t -> b Sink.t -> 'a list -> b
|
|
||||||
= fun ~src sink l -> match sink with
|
|
||||||
| Sink.List f ->
|
|
||||||
f (fun sink' -> List.map (src.visit sink') l)
|
|
||||||
| Sink.Tuple _ -> tuple ~src sink l
|
|
||||||
| Sink.Map (sink', f) -> f (list_ ~src sink' l)
|
|
||||||
| Sink.Fix f -> list_ ~src (f sink) l
|
|
||||||
| _ -> __error "get List, but expected %s" (Sink.__expected sink)
|
|
||||||
|
|
||||||
and record : type b. src:'a t -> b Sink.t -> (string*'a) list -> b
|
|
||||||
= fun ~src sink l -> match sink with
|
|
||||||
| Sink.Record r ->
|
|
||||||
(* fold over the expected record fields *)
|
|
||||||
let rec build_record
|
|
||||||
= function
|
|
||||||
| Sink.RecordStop x -> x
|
|
||||||
| Sink.RecordField (name, sink', cont) ->
|
|
||||||
let src_field = _get_field l name in
|
|
||||||
let sink_field = src.visit sink' src_field in
|
|
||||||
build_record (cont sink_field)
|
|
||||||
in build_record r
|
|
||||||
| Sink.Map (sink', f) -> f (record ~src sink' l)
|
|
||||||
| Sink.Fix f -> record ~src (f sink) l
|
|
||||||
| _ -> __error "get Record, but expected %s" (Sink.__expected sink)
|
|
||||||
|
|
||||||
and build_hlist : 't. src:'a t -> 'a list -> 't Sink.hlist -> 't
|
|
||||||
= fun ~src l t_sink -> match l, t_sink with
|
|
||||||
| [], Sink.HNil t -> t
|
|
||||||
| [], _ ->
|
|
||||||
__error "not enough tuple components"
|
|
||||||
| _::_, Sink.HNil _ ->
|
|
||||||
__error "too many tuple components (%d too many)" (List.length l)
|
|
||||||
| x::l', Sink.HCons (sink', cont) ->
|
|
||||||
let y = src.visit sink' x in
|
|
||||||
build_hlist ~src l' (cont y)
|
|
||||||
|
|
||||||
and tuple : type b. src:'a t -> b Sink.t -> 'a list -> b
|
|
||||||
= fun ~src sink l -> match sink with
|
|
||||||
| Sink.Tuple t_sink ->
|
|
||||||
(* fold over the expected tuple component *)
|
|
||||||
build_hlist ~src l t_sink
|
|
||||||
| Sink.List _ -> list_ ~src sink l (* adapt *)
|
|
||||||
| Sink.Map (sink', f) -> f (tuple ~src sink' l)
|
|
||||||
| Sink.Fix f -> tuple ~src (f sink) l
|
|
||||||
| _ -> __error "get Tuple, but expected %s" (Sink.__expected sink)
|
|
||||||
|
|
||||||
and sum : type b. src:'a t -> b Sink.t -> string -> 'a list -> b
|
|
||||||
= fun ~src sink name s -> match sink with
|
|
||||||
| Sink.Sum f ->
|
|
||||||
let l_sink = f name in
|
|
||||||
build_hlist ~src s l_sink
|
|
||||||
| Sink.Map (sink', f) -> f (sum ~src sink' name s)
|
|
||||||
| Sink.Fix f -> sum ~src (f sink) name s
|
|
||||||
| _ -> __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
|
||||||
|
|
|
||||||
181
conv.mli
181
conv.mli
|
|
@ -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,96 +148,36 @@ 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 *)
|
||||||
|
module UniversalSource : sig
|
||||||
|
type 'a t = {
|
||||||
|
visit : 'b. 'b Sink.t -> 'a -> 'b;
|
||||||
|
}
|
||||||
|
|
||||||
and 't tuple_src =
|
val unit_ : 'b Sink.t -> 'b
|
||||||
| TupleField : 'a t * ('t -> 'a) * 't tuple_src -> 't tuple_src
|
val bool_ : 'b Sink.t -> bool -> 'b
|
||||||
| TupleStop : 't tuple_src
|
val float_ : 'b Sink.t -> float -> 'b
|
||||||
|
val int_ : 'b Sink.t -> int -> 'b
|
||||||
and sum_src =
|
val string_ : 'b Sink.t -> string -> 'b
|
||||||
| SumCons : 'a t * 'a * sum_src -> sum_src
|
val list_ : src:'a t -> 'b Sink.t -> 'a list -> 'b
|
||||||
| SumNil : sum_src
|
val record : src:'a t -> 'b Sink.t -> (string*'a) list -> 'b
|
||||||
|
val tuple : src:'a t -> 'b Sink.t -> 'a list -> 'b
|
||||||
val unit_ : unit t
|
val sum : src:'a t -> 'b Sink.t -> string -> 'a list -> 'b
|
||||||
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 = {
|
|
||||||
visit : 'b. 'b Sink.t -> 'a -> 'b;
|
|
||||||
}
|
|
||||||
|
|
||||||
val unit_ : 'b Sink.t -> 'b
|
|
||||||
val bool_ : 'b Sink.t -> bool -> 'b
|
|
||||||
val float_ : 'b Sink.t -> float -> 'b
|
|
||||||
val int_ : 'b Sink.t -> int -> 'b
|
|
||||||
val string_ : 'b Sink.t -> string -> 'b
|
|
||||||
val list_ : src:'a t -> 'b Sink.t -> '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 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 *)
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue