mirror of
https://github.com/c-cube/ocaml-containers.git
synced 2025-12-06 03:05:28 -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)))
|
||||
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
|
||||
(** A specific sink that requires a given shape to produce
|
||||
a value of type 'a *)
|
||||
|
|
@ -155,264 +288,124 @@ module Sink = struct
|
|||
| List _ -> ExpectList
|
||||
| (Fix f) as sink -> expected (f 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
|
||||
|
||||
module Source = 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
|
||||
module UniversalSource = struct
|
||||
type 'a t = {
|
||||
visit : 'b. 'b Sink.t -> 'a -> 'b;
|
||||
}
|
||||
|
||||
and 'r record_src =
|
||||
| RecordField : string * ('r -> 'a) * 'a t * 'r record_src -> 'r record_src
|
||||
| RecordStop : 'r record_src
|
||||
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)
|
||||
|
||||
and 't tuple_src =
|
||||
| TupleField : 'a t * ('t -> 'a) * 't tuple_src -> 't tuple_src
|
||||
| TupleStop : 't tuple_src
|
||||
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)
|
||||
|
||||
and sum_src =
|
||||
| SumCons : 'a t * 'a * sum_src -> sum_src
|
||||
| SumNil : sum_src
|
||||
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 unit_ = Unit
|
||||
let bool_ = Bool
|
||||
let float_ = Float
|
||||
let int_ = Int
|
||||
let string_ = String
|
||||
let list_ e = List e
|
||||
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 map f src = Map (src, f)
|
||||
let array_ src = map Array.to_list (list_ src)
|
||||
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 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 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)
|
||||
|
||||
let tuple_field src get cont = TupleField (src,get,cont)
|
||||
let tuple_stop = TupleStop
|
||||
let tuple t = Tuple t
|
||||
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)
|
||||
|
||||
let pair a b =
|
||||
tuple (tuple_field a fst (tuple_field b snd tuple_stop))
|
||||
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)
|
||||
|
||||
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)))
|
||||
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)
|
||||
|
||||
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 = {
|
||||
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
|
||||
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
|
||||
|
||||
let rec into : type a b. a Source.t -> b Sink.Universal.t -> a -> b =
|
||||
let open Sink.Universal in
|
||||
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
|
||||
let from (src:'a UniversalSource.t) (sink:'b Sink.t) (x:'a) : 'b =
|
||||
src.UniversalSource.visit sink x
|
||||
|
||||
(** {6 Exemples} *)
|
||||
|
||||
|
|
@ -428,7 +421,7 @@ module Json = struct
|
|||
]
|
||||
|
||||
let source =
|
||||
let module U = Source.Universal in
|
||||
let module U = UniversalSource in
|
||||
let rec visit : type b. b Sink.t -> t -> b =
|
||||
fun sink x -> match x with
|
||||
| `Int i -> U.int_ sink i
|
||||
|
|
@ -450,8 +443,8 @@ module Json = struct
|
|||
and src = { U.visit=visit; } in
|
||||
src
|
||||
|
||||
let sink : t Sink.Universal.t =
|
||||
let open Sink.Universal in
|
||||
let sink : t UniversalSink.t =
|
||||
let open UniversalSink in
|
||||
{ unit_ = `Null;
|
||||
bool_ = (fun b -> `Bool b);
|
||||
float_ = (fun f -> `Float f);
|
||||
|
|
@ -472,7 +465,7 @@ module Sexp = struct
|
|||
| List of t list
|
||||
|
||||
let source =
|
||||
let module U = Source.Universal in
|
||||
let module U = UniversalSource in
|
||||
let rec visit : type b. b Sink.t -> t -> b =
|
||||
fun sink x -> match x, Sink.expected sink with
|
||||
| Atom s, Sink.ExpectSum -> U.sum ~src sink s []
|
||||
|
|
@ -489,7 +482,7 @@ module Sexp = struct
|
|||
src
|
||||
|
||||
let sink =
|
||||
let open Sink.Universal in
|
||||
let open UniversalSink in
|
||||
{ unit_ = List [];
|
||||
bool_ = (fun b -> Atom (string_of_bool b));
|
||||
float_ = (fun f -> Atom (string_of_float f));
|
||||
|
|
@ -521,7 +514,7 @@ module Bencode = struct
|
|||
| Assoc of (string * t) list
|
||||
|
||||
let source =
|
||||
let module U = Source.Universal in
|
||||
let module U = UniversalSource in
|
||||
let rec visit : type b. b Sink.t -> t -> b =
|
||||
fun sink x -> match x, Sink.expected sink with
|
||||
| String s, Sink.ExpectSum -> U.sum ~src sink s []
|
||||
|
|
@ -536,7 +529,7 @@ module Bencode = struct
|
|||
src
|
||||
|
||||
let sink =
|
||||
let open Sink.Universal in
|
||||
let open UniversalSink in
|
||||
{ unit_ = Int 0;
|
||||
bool_ = (fun b -> Int (if b then 1 else 0));
|
||||
float_ = (fun f -> String (string_of_float f));
|
||||
|
|
@ -571,7 +564,7 @@ module Point = struct
|
|||
yield_record {x;y;color;prev}
|
||||
))
|
||||
|
||||
let source =
|
||||
let rec source =
|
||||
Source.(record_fix
|
||||
(fun self ->
|
||||
field "x" (fun p -> p.x) int_ @@
|
||||
|
|
@ -605,9 +598,9 @@ module Lambda = struct
|
|||
|
||||
let source = Source.(sum_fix
|
||||
(fun self t -> match t with
|
||||
| Var s -> "var", sum_cons string_ s @@ sum_nil
|
||||
| App (t1, t2) -> "app", sum_cons self t1 @@ sum_cons self t2 @@ sum_nil
|
||||
| Lambda (s, t) -> "lam", sum_cons string_ s @@ sum_cons self t @@ sum_nil
|
||||
| Var s -> "var", hcons string_ s @@ hnil
|
||||
| App (t1, t2) -> "app", hcons self t1 @@ hcons self t2 @@ hnil
|
||||
| Lambda (s, t) -> "lam", hcons string_ s @@ hcons self t @@ hnil
|
||||
))
|
||||
|
||||
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
|
||||
|
||||
(** {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}
|
||||
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
|
||||
(** A specific sink that requires a given shape to produce
|
||||
a value of type 'a *)
|
||||
type 'a t
|
||||
type 'a t (** How to produce values of type 'a *)
|
||||
|
||||
and '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
|
||||
(** To be used by sources that have ambiguities to know what is expected.
|
||||
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
|
||||
|
||||
(** {6 Sources}
|
||||
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
|
||||
(** {6 Universal source}
|
||||
|
||||
and 'r record_src =
|
||||
| RecordField : string * ('r -> 'a) * 'a t * 'r record_src -> 'r record_src
|
||||
| RecordStop : 'r record_src
|
||||
source from type 'a, where 'a is typically a serialization
|
||||
format. This is used to translate from 'a to some other type.
|
||||
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 =
|
||||
| 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 = {
|
||||
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
|
||||
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
|
||||
|
||||
(** {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 *)
|
||||
|
||||
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 *)
|
||||
|
||||
(* TODO for format conversion
|
||||
|
|
@ -196,8 +197,8 @@ module Json : sig
|
|||
| `Assoc of (string * t) list
|
||||
]
|
||||
|
||||
val source : t Source.Universal.t
|
||||
val sink : t Sink.Universal.t
|
||||
val source : t UniversalSource.t
|
||||
val sink : t UniversalSink.t
|
||||
end
|
||||
|
||||
module Sexp : sig
|
||||
|
|
@ -205,8 +206,8 @@ module Sexp : sig
|
|||
| Atom of string
|
||||
| List of t list
|
||||
|
||||
val source : t Source.Universal.t
|
||||
val sink : t Sink.Universal.t
|
||||
val source : t UniversalSource.t
|
||||
val sink : t UniversalSink.t
|
||||
val fmt : Format.formatter -> t -> unit (* for debug *)
|
||||
end
|
||||
|
||||
|
|
@ -217,8 +218,8 @@ module Bencode : sig
|
|||
| List of t list
|
||||
| Assoc of (string * t) list
|
||||
|
||||
val source : t Source.Universal.t
|
||||
val sink : t Sink.Universal.t
|
||||
val source : t UniversalSource.t
|
||||
val sink : t UniversalSink.t
|
||||
end
|
||||
|
||||
(** Tests *)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue