Monadic binary (de)serialization API for OCaml

binsec.ml

type 'a writer = Buffer.t -> 'a -> unit;;
type 'a reader = string -> int -> ('a * int);;

let ($) a b = a b;;
let id x = x;;

let lift_llio_writer (l: Buffer.t -> 'b -> unit): ('a -> 'b) -> 'a writer =
    fun f -> fun b a ->
        let v = f a in
        l b v;;

let lift_llio_reader (l: string -> int -> ('a * int)): 'a reader = l;;

let write_int32: 'a. ('a -> int32) -> 'a writer =
    fun f -> lift_llio_writer Llio.int32_to f
and read_int32 = lift_llio_reader Llio.int32_from;;

let write_int64: 'a. ('a -> int64) -> 'a writer =
    fun f -> lift_llio_writer Llio.int64_to f
and read_int64 = lift_llio_reader Llio.int64_from;;

let write_float: 'a. ('a -> float) -> 'a writer =
    fun f -> lift_llio_writer Llio.float_to f
and read_float = lift_llio_reader Llio.float_from;;

let write_bool: 'a. ('a -> bool) -> 'a writer =
    fun f -> lift_llio_writer Llio.bool_to f
and read_bool = lift_llio_reader Llio.bool_from;;

let write_string: 'a. ('a -> string) -> 'a writer =
    fun f -> lift_llio_writer Llio.string_to f
and read_string = lift_llio_reader Llio.string_from;;

let write_option: 'a. (('c -> 'd) -> 'b writer) -> ('a -> 'b option) -> 'a writer =
    fun w -> fun f -> lift_llio_writer (Llio.option_to (w id)) f
and read_option: 'a. 'a reader -> 'a option reader =
    fun f -> lift_llio_reader (Llio.option_from f);;

let write_list (w: ('c -> 'd) -> 'b writer) (f: 'a -> 'b list): 'a writer =
    fun b a ->
        let vs = f a in
        let l = List.length vs in
        let () = write_int32 id b (Int32.of_int l) in
        List.iter (w id b) vs
and read_list (r: 'a reader): 'a list reader = fun b o ->
    let (l, o') = read_int32 b o in
    let rec helper o'' acc = function
        | 0 -> (acc, o'')
        | n ->
            let (v, o3) = r b o'' in
            helper o3 (v :: acc) (pred n)
    in
    let (vs, o4) = helper o' [] (Int32.to_int l) in
    (List.rev vs, o4);;


let lift_writer (w: 'b writer): ('a -> 'b) -> 'a writer = fun f b a ->
    w b $ f a;;

let run_writer ?buffer_size:(bs=64) (w: 'a writer) (a: 'a): Buffer.t =
    let b = Buffer.create bs in
    let () = w b a in
    b;;

let bind_writer (f: 'a writer) (g: 'a writer): ('a writer) = fun b a ->
    let () = f b a in
    g b a;;

let (>>) = bind_writer;;


let bind_reader (f: 'a reader) (g: 'a -> 'b reader): 'b reader = fun b o ->
    let (v, o') = f b o in
    g v b o';;

let (>>=) = bind_reader;;

let return_reader (a: 'a): 'a reader = fun _ o ->
    (a, o);;

let return = return_reader;;


(* Demonstration code *)
type address = {
    street: string;
    number: int;
    postal_code: int;
    city: string;
    country: string;
}

type all_types = {
    i32: int32;
    i64: int64;
    f: float;
    b: bool;
    s: string;
    l: int32 list;
    o: string option;
    c: string option list option;
}

type record = {
    name: string;
    age: int;
    tags: string list;
    addresses: address list;
    test: all_types;
}

let write_address: address writer =
    write_string (fun a -> a.street) >>
    write_int32 (fun a -> Int32.of_int a.number) >>
    write_int32 (fun a -> Int32.of_int a.postal_code) >>
    write_string (fun a -> a.city) >>
    write_string (fun a -> a.country)

let read_address: address reader =
    read_string >>= fun street ->
    read_int32 >>= fun number ->
    read_int32 >>= fun postal_code ->
    read_string >>= fun city ->
    read_string >>= fun country ->
    return { street=street; number=Int32.to_int number;
             postal_code=Int32.to_int postal_code; city=city;
             country=country; };;

let write_all_types: all_types writer =
    write_int32 (fun a -> a.i32) >>
    write_int64 (fun a -> a.i64) >>
    write_float (fun a -> a.f) >>
    write_bool (fun a -> a.b) >>
    write_string (fun a -> a.s) >>
    write_list write_int32 (fun a -> a.l) >>
    write_option write_string (fun a -> a.o) >>
    write_option (write_list (write_option write_string)) (fun a -> a.c)
and read_all_types: all_types reader =
    read_int32 >>= fun i32 ->
    read_int64 >>= fun i64 ->
    read_float >>= fun f ->
    read_bool >>= fun b ->
    read_string >>= fun s ->
    read_list read_int32 >>= fun l ->
    read_option read_string >>= fun o ->
    read_option (read_list (read_option read_string)) >>= fun c ->
    return { i32=i32; i64=i64; f=f; b=b; s=s; l=l; o=o; c=c; };;


let write_record: record writer =
    write_string (fun r -> r.name) >>
    write_int32 (fun r -> Int32.of_int r.age) >>
    write_list write_string (fun r -> r.tags) >>
    write_list (lift_writer write_address) (fun r -> r.addresses) >>
    (lift_writer write_all_types) (fun r -> r.test);;

let read_record: record reader =
    read_string >>= fun name ->
    read_int32 >>= fun age ->
    read_list read_string >>= fun tags ->
    read_list read_address >>= fun addresses ->
    read_all_types >>= fun test ->
    return { name=name; age=Int32.to_int age; tags=tags; addresses=addresses; 
             test=test };;

let r = { name="Nicolas"; age=25; tags=["architect"; "developer"]; 
          addresses=[ { street="Whoknows"; number=1; 
                        postal_code=1234; city="Somewhere";
                        country="Belgium"; };
                      { street="Workstreet"; number=19;
                        postal_code=4321; city="Workplace";
                        country="Belgium"; } ];
          test={ i32=Int32.of_int 32768; i64=Int64.of_int (-128); f=0.0001;
                 b=true; s="test"; l=[]; o=Some "demo";
                 c=Some [Some "foo"; None; Some "bar"; ] } } in
let s = run_writer write_record r in
let s' = Buffer.contents s in
let () = print_string s' in
let (r', o) = read_record s' 0 in
let () = assert (r = r') in
assert (o = (Buffer.length s));;