mirror of
https://github.com/c-cube/ocaml-containers.git
synced 2025-12-07 11:45:31 -05:00
big update of Conv, with universal sources and sinks
and GADTs for describing other sources and sinks
This commit is contained in:
Simon Cruanes
parent
57bb863f78
commit
016a557a37
2 changed files with 351 additions and 68 deletions
315
conv.ml
315
conv.ml
|
|
@ -28,94 +28,289 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|||
|
||||
exception ConversionFailure of string
|
||||
|
||||
(* error-raising function *)
|
||||
let __error msg =
|
||||
let b = Buffer.create 15 in
|
||||
Printf.bprintf b "conversion error: ";
|
||||
Printf.kbprintf
|
||||
(fun b -> raise (ConversionFailure (Buffer.contents b)))
|
||||
b msg
|
||||
|
||||
module Sink = struct
|
||||
(** A specific sink that requires a given shape to produce
|
||||
* a value of type 'a *)
|
||||
type 'a t =
|
||||
| Int : (int -> 'a) -> 'a t
|
||||
| String : (string -> 'a) -> 'a t
|
||||
| List : (('b t -> 'b list) -> 'a) -> 'a t
|
||||
| RecordField : string * 'b t * ('b -> 'a t) -> 'a t
|
||||
| Return : 'a -> 'a t
|
||||
| Record : 'a record_sink -> 'a t
|
||||
| Tuple : 'a tuple_sink -> 'a t
|
||||
| Sum : (string -> ('b t -> 'b) -> 'a) -> 'a t
|
||||
| Map : 'a t * ('a -> 'b) -> 'b t
|
||||
|
||||
let return x = Return x
|
||||
and 'r record_sink =
|
||||
| RecordField : string * 'a t * ('a -> 'r record_sink) -> 'r record_sink
|
||||
| RecordStop : 'r -> 'r record_sink
|
||||
|
||||
and 't tuple_sink =
|
||||
| TupleField : 'a t * ('a -> 't tuple_sink) -> 't tuple_sink
|
||||
| TupleStop : 't -> 't tuple_sink
|
||||
|
||||
and 's sum_sink =
|
||||
| SumSink : (string -> ('b t -> 'b) -> 's) -> 's sum_sink
|
||||
|
||||
let rec __expected : type a. a t -> string = function
|
||||
| Int _ -> "int"
|
||||
| String _ -> "string"
|
||||
| List _ -> "list"
|
||||
| Record _ -> "record"
|
||||
| Tuple _ -> "tuple"
|
||||
| Sum _ -> "sum"
|
||||
| Map (sink', _) -> __expected sink'
|
||||
|
||||
let int_ = Int (fun i -> i)
|
||||
let string_ = String (fun s -> s)
|
||||
|
||||
let list_ e =
|
||||
List (fun k -> let l = k e in l)
|
||||
|
||||
let map f sink = Map (sink, f)
|
||||
let array_ sink =
|
||||
map Array.of_list (list_ sink)
|
||||
|
||||
let (-->) a b = a, b
|
||||
let (|:|) (name,sink) cont = RecordField (name,sink,cont)
|
||||
let yield_record r = RecordStop r
|
||||
let record r = Record r
|
||||
|
||||
let (|+|) sink cont = TupleField (sink, cont)
|
||||
let yield_tuple t = TupleStop t
|
||||
let tuple t = Tuple t
|
||||
|
||||
let pair a b =
|
||||
tuple (
|
||||
a |+| fun x ->
|
||||
b |+| fun y ->
|
||||
yield_tuple (x,y)
|
||||
)
|
||||
|
||||
let triple a b c =
|
||||
tuple (
|
||||
a |+| fun x ->
|
||||
b |+| fun y ->
|
||||
c |+| fun z ->
|
||||
yield_tuple (x,y,z)
|
||||
)
|
||||
|
||||
let quad a b c d =
|
||||
tuple (
|
||||
a |+| fun x ->
|
||||
b |+| fun y ->
|
||||
c |+| fun z ->
|
||||
d |+| fun w ->
|
||||
yield_tuple (x,y,z,w)
|
||||
)
|
||||
|
||||
let sum f = Sum f
|
||||
|
||||
(** Universal sink, such as a serialization format *)
|
||||
class type ['a] universal = object
|
||||
method int_ : int -> 'a
|
||||
method string_ : string -> 'a
|
||||
method list_ : 'a list -> 'a
|
||||
method record : (string*'a) list -> 'a
|
||||
method tuple : 'a list -> 'a
|
||||
method sum : string -> 'a -> 'a
|
||||
end
|
||||
end
|
||||
|
||||
module Source = struct
|
||||
type 'a t = {
|
||||
convert : 'b. 'b Sink.t -> 'a -> 'b;
|
||||
}
|
||||
(** A specific source that follows the shape of the type 'a *)
|
||||
type 'a 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 * 'b t * 'b) -> 'a t
|
||||
| Map : 'a t * ('b -> 'a) -> 'b t
|
||||
|
||||
let int_ =
|
||||
let convert sink x = match sink with
|
||||
| Sink.Int f -> f x
|
||||
| _ -> raise (ConversionFailure "expected int")
|
||||
in { convert; }
|
||||
and 'r record_src =
|
||||
| RecordField : string * ('r -> 'a) * 'a t * 'r record_src -> 'r record_src
|
||||
| RecordStop : 'r record_src
|
||||
|
||||
let string_ =
|
||||
let convert sink x = match sink with
|
||||
| Sink.String f -> f x
|
||||
| _ -> raise (ConversionFailure "expected string")
|
||||
in { convert; }
|
||||
and 't tuple_src =
|
||||
| TupleField : 'a t * ('t -> 'a) * 't tuple_src -> 't tuple_src
|
||||
| TupleStop : 't tuple_src
|
||||
|
||||
let list_ e =
|
||||
let convert sink l = match sink with
|
||||
| Sink.List f -> f (fun sink' -> List.map (e.convert sink') l)
|
||||
| _ -> raise (ConversionFailure "expected list")
|
||||
in
|
||||
{ convert; }
|
||||
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 record_field name get src' cont =
|
||||
RecordField (name,get,src',cont)
|
||||
let record_stop = RecordStop
|
||||
let record r = Record r
|
||||
let (@@@) a b = a b
|
||||
|
||||
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 f = Sum f
|
||||
|
||||
(* 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
|
||||
|
||||
class virtual ['a] universal = object(self)
|
||||
|
||||
method private int_ : 'b. 'b Sink.t -> int -> 'b
|
||||
= fun sink i -> match sink with
|
||||
| Sink.Int f -> f i
|
||||
| Sink.String f -> f (string_of_int i)
|
||||
| Sink.Map (sink', f) -> f (self#int_ sink' i)
|
||||
| _ -> __error "get Int, but expected %s" (Sink.__expected sink)
|
||||
|
||||
method private string_ : 'b. 'b Sink.t -> string -> 'b
|
||||
= fun sink s -> match sink with
|
||||
| Sink.String f -> f s
|
||||
| Sink.Int f ->
|
||||
begin try f (int_of_string s)
|
||||
with Invalid_argument _ -> __error "get String, but expected Int"
|
||||
end
|
||||
| Sink.Map (sink', f) -> f (self#string_ sink' s)
|
||||
| _ -> __error "get String, but expected %s" (Sink.__expected sink)
|
||||
|
||||
method private list_ : 'b. 'b Sink.t -> 'a list -> 'b
|
||||
= fun sink l -> match sink with
|
||||
| Sink.List f ->
|
||||
f (fun sink' -> List.map (self#visit sink') l)
|
||||
| Sink.Map (sink', f) -> f (self#list_ sink' l)
|
||||
| _ -> __error "get List, but expected %s" (Sink.__expected sink)
|
||||
|
||||
method private record : 'b. 'b Sink.t -> (string*'a) list -> 'b
|
||||
= fun sink l -> match sink with
|
||||
| Sink.Record r ->
|
||||
(* fold over the expected record fields *)
|
||||
let rec build_record : 'r. 'r Sink.record_sink -> 'r
|
||||
= function
|
||||
| Sink.RecordStop x -> x
|
||||
| Sink.RecordField (name, sink', cont) ->
|
||||
let src_field = _get_field l name in
|
||||
let sink_field = self#visit sink' src_field in
|
||||
build_record (cont sink_field)
|
||||
in build_record r
|
||||
| Sink.Map (sink', f) -> f (self#record sink' l)
|
||||
| _ -> __error "get Record, but expected %s" (Sink.__expected sink)
|
||||
|
||||
method private tuple : 'b. 'b Sink.t -> 'a list -> 'b
|
||||
= fun sink l -> match sink with
|
||||
| Sink.Tuple t_sink ->
|
||||
(* fold over the expected tuple component *)
|
||||
let rec build_tuple : 't. 'a list -> 't Sink.tuple_sink -> 't
|
||||
= fun l t_sink -> match l, t_sink with
|
||||
| [], Sink.TupleStop t -> t
|
||||
| [], _ ->
|
||||
__error "not enough tuple components"
|
||||
| _::_, Sink.TupleStop _ ->
|
||||
__error "too many tuple components (%d too many)" (List.length l)
|
||||
| x::l', Sink.TupleField (sink', cont) ->
|
||||
let y = self#visit sink' x in
|
||||
build_tuple l' (cont y)
|
||||
in build_tuple l t_sink
|
||||
| Sink.Map (sink', f) -> f (self#tuple sink' l)
|
||||
| _ -> __error "get Tuple, but expected %s" (Sink.__expected sink)
|
||||
|
||||
method private sum : 'b. 'b Sink.t -> string -> 'a -> 'b
|
||||
= fun sink name s -> match sink with
|
||||
| Sink.Sum f ->
|
||||
f name (fun sink' -> self#visit sink' s)
|
||||
| Sink.Map (sink', f) -> f (self#sum sink' name s)
|
||||
| _ -> __error "get Sum(%s), but expected %s" name (Sink.__expected sink)
|
||||
|
||||
method virtual visit : 'b. 'b Sink.t -> 'a -> 'b
|
||||
end
|
||||
end
|
||||
|
||||
let conv ~src ~sink x = src.Source.convert sink x
|
||||
let rec into : type a b. a Source.t -> b Sink.universal -> a -> b =
|
||||
fun src sink x -> match src with
|
||||
| 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 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 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 name, src', y = f x in
|
||||
let z = into src' sink y in
|
||||
sink#sum name z
|
||||
| Source.Map (src', f) -> into src' sink (f x)
|
||||
|
||||
(* test for records
|
||||
* TODO: continue, and provide a good API for records,
|
||||
* recursive types and tuples. *)
|
||||
let from (src:'a Source.universal) (sink:'b Sink.t) (x:'a) : 'b = src#visit sink x
|
||||
|
||||
(* test for records *)
|
||||
|
||||
type point = {
|
||||
x:int;
|
||||
y:int;
|
||||
color:string;
|
||||
}
|
||||
|
||||
let point_sink : point Sink.t =
|
||||
Sink.RecordField ("x", Sink.int_,
|
||||
(fun x -> Sink.RecordField ("color", Sink.string_,
|
||||
(fun color -> Sink.return {x;color;}))))
|
||||
let point_sink =
|
||||
Sink.(record (
|
||||
"x" --> int_ |:| fun x ->
|
||||
"y" --> int_ |:| fun y ->
|
||||
"color" --> string_ |:| fun color ->
|
||||
yield_record {x;y;color}
|
||||
))
|
||||
|
||||
type 'r record_source =
|
||||
| RSStop : 'r record_source
|
||||
| RSField : string * ('r -> 'a) * 'a Source.t * 'r record_source -> 'r record_source
|
||||
|
||||
let mk_record_src rs =
|
||||
let rec convert : 'b. 'b Sink.t -> 'a -> 'b
|
||||
= fun sink x -> match sink with
|
||||
| Sink.Return y -> y
|
||||
| Sink.RecordField (name, sink', kont) ->
|
||||
search rs name sink' x kont
|
||||
| _ -> raise (ConversionFailure "expected record")
|
||||
and search
|
||||
: 'b 'c. 'a record_source -> string -> 'b Sink.t -> 'a -> ('b -> 'c Sink.t) -> 'c
|
||||
= fun rs name sink' x kont -> match rs with
|
||||
| RSStop -> raise (ConversionFailure ("could not find field "^name))
|
||||
| RSField (name', get, src, _) when name = name' ->
|
||||
(* use source to encode x *)
|
||||
let new_sink = kont (conv ~src ~sink:sink' (get x)) in
|
||||
convert new_sink x
|
||||
| RSField (_, _, _, rs') ->
|
||||
(* search further *)
|
||||
search rs' name sink' x kont
|
||||
in Source.({ convert; })
|
||||
|
||||
let point_source : point Source.t =
|
||||
mk_record_src (
|
||||
RSField ("x", (fun p -> p.x), Source.int_,
|
||||
RSField ("color", (fun p -> p.color), Source.string_,
|
||||
RSStop ))
|
||||
)
|
||||
Source.(record (
|
||||
record_field "x" (fun p -> p.x) int_ @@@
|
||||
record_field "y" (fun p -> p.y) int_ @@@
|
||||
record_field "color" (fun p -> p.color) string_ @@@
|
||||
record_stop
|
||||
))
|
||||
|
||||
let p = {x=1; color="yellow"; }
|
||||
let p = {x=1; y=42; color="yellow"; }
|
||||
|
||||
(* TODO tests *)
|
||||
|
|
|
|||
104
conv.mli
104
conv.mli
|
|
@ -29,29 +29,117 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|||
exception ConversionFailure of string
|
||||
|
||||
module Sink : sig
|
||||
(** A specific sink that requires a given shape to produce
|
||||
* a value of type 'a *)
|
||||
type 'a t =
|
||||
| Int : (int -> 'a) -> 'a t
|
||||
| String : (string -> 'a) -> 'a t
|
||||
| List : (('b t -> 'b list) -> 'a) -> 'a t
|
||||
| RecordField : string * 'b t * ('b -> 'a t) -> 'a t
|
||||
| Return : 'a -> 'a t
|
||||
| Record : 'a record_sink -> 'a t
|
||||
| Tuple : 'a tuple_sink -> 'a t
|
||||
| Sum : (string -> ('b t -> 'b) -> 'a) -> 'a t
|
||||
| Map : 'a t * ('a -> 'b) -> 'b t
|
||||
|
||||
val return : 'a -> 'a t
|
||||
and 'r record_sink =
|
||||
| RecordField : string * 'a t * ('a -> 'r record_sink) -> 'r record_sink
|
||||
| RecordStop : 'r -> 'r record_sink
|
||||
|
||||
and 't tuple_sink =
|
||||
| TupleField : 'a t * ('a -> 't tuple_sink) -> 't tuple_sink
|
||||
| TupleStop : 't -> 't tuple_sink
|
||||
|
||||
and 's sum_sink =
|
||||
| SumSink : (string -> ('b t -> 'b) -> 's) -> 's sum_sink
|
||||
|
||||
val int_ : int t
|
||||
val string_ : string t
|
||||
val list_ : 'a t -> 'a list t
|
||||
|
||||
val map : ('a -> 'b) -> 'a t -> 'b t
|
||||
val array_ : 'a t -> 'a array t
|
||||
|
||||
val (-->) : 'a -> 'b -> 'a * 'b
|
||||
val (|:|) : (string * 'a t) -> ('a -> 'r record_sink) -> 'r record_sink
|
||||
val yield_record : 'r -> 'r record_sink
|
||||
val record : 'r record_sink -> 'r t
|
||||
|
||||
val (|+|) : 'a t -> ('a -> 't tuple_sink) -> 't tuple_sink
|
||||
val yield_tuple : 't -> 't tuple_sink
|
||||
val tuple : 't tuple_sink -> '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 : (string -> ('b t -> 'b) -> 'a) -> 'a t
|
||||
|
||||
(** Universal sink, such as a serialization format *)
|
||||
class type ['a] universal = object
|
||||
method int_ : int -> 'a
|
||||
method string_ : string -> 'a
|
||||
method list_ : 'a list -> 'a
|
||||
method record : (string*'a) list -> 'a
|
||||
method tuple : 'a list -> 'a
|
||||
method sum : string -> 'a -> 'a
|
||||
end
|
||||
end
|
||||
|
||||
module Source : sig
|
||||
type 'a t = {
|
||||
convert : 'b. 'b Sink.t -> 'a -> 'b;
|
||||
}
|
||||
(** A specific source that follows the shape of the type 'a *)
|
||||
type 'a 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 * 'b t * 'b) -> 'a t
|
||||
| Map : 'a t * ('b -> 'a) -> 'b 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
|
||||
|
||||
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 record_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 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 (@@@) : ('a -> 'b) -> 'a -> 'b
|
||||
|
||||
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 * 'b t * 'b) -> 'a t
|
||||
|
||||
(** Universal source from type 'a. A universal type should inherit from it
|
||||
and implement the visit method by calling self-methods. *)
|
||||
class virtual ['a] universal : object
|
||||
method private int_ : 'b. 'b Sink.t -> int -> 'b
|
||||
method private string_ : 'b. 'b Sink.t -> string -> 'b
|
||||
method private list_ : 'b. 'b Sink.t -> 'a list -> 'b
|
||||
method private record : 'b. 'b Sink.t -> (string*'a) list -> 'b
|
||||
method private tuple : 'b. 'b Sink.t -> 'a list -> 'b
|
||||
method private sum : 'b. 'b Sink.t -> string -> 'a -> 'b
|
||||
method virtual visit : 'b. 'b Sink.t -> 'a -> 'b
|
||||
end
|
||||
end
|
||||
|
||||
val conv : src:'a Source.t -> sink:'b Sink.t -> 'a -> 'b
|
||||
(** Main conversion function *)
|
||||
val into : 'a Source.t -> 'b Sink.universal -> 'a -> 'b
|
||||
(** Conversion to universal sink *)
|
||||
|
||||
val from : 'a Source.universal -> 'b Sink.t -> 'a -> 'b
|
||||
(** Conversion from universal source *)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue