Source

cadastr / src / cd_Ser.ml

(* it's dumb for now, but it's required for parvel. *)


open Cd_All; open Cdt;
open Printf;


value ti_int = (ti_int :> ti int);
value ti_string = (ti_string :> ti string);
value ti_unit = (ti_unit :> ti unit);


(******************************************************)





(******************************************************)

value marshal_ser typename x =
  Marshal.to_string (typename, x) []
;

value marshal_deser (type a) typename s =
  let (tn, (x : a)) = Marshal.from_string s 0 in
  if tn <> typename
  then
    let () = eprintf "deser: expected %S, got %S\n%!" typename tn in
    raise Deser
  else x
;





value ustrs_of_uvals
 : array ubox -> array string
 = fun uvals ->
     let ustrs : array string =
       Array.map
         (fun ub ->
            let ser = get_meth_untyped "ser.marshal" ub.ub_uti in
            uget_exn ti_string (u_app ser ub)
         )
         uvals
     in
       ustrs
;


value rec ti_ser_td
 : ti 'a -> type_desc -> ('a -> string)
 = fun ti td ->
     match td with
     [ Simple tn ->
         fun a -> marshal_ser tn a
     | Sum_type destr _constr ->
         fun a ->
           let (variant_name, disp) = destr (ubox ti a) in
           let () = printf "ti_ser: variant_name = %S\n%!" variant_name in
           let uvals = disp "ser.marshal" in
           let ustrs = ustrs_of_uvals uvals in
           let () = Array.iter (printf "ti_ser: %S\n%!") ustrs in
           let () = print_newline () in
           marshal_ser ti#type_name (variant_name, ustrs)

     | Tuple destr _utis _constr ->
         fun a ->
           let uvals = destr (ubox ti a) in
           let ustrs = ustrs_of_uvals uvals in
           marshal_ser ti#type_name ustrs

     | Record_type _
     | Lambda _ _ _
         ->
           assert False
(*
     | Record_type of (R.ubox -> array (field_name * R.ubox))
     | Lambda of R.uti and R.uti and (unit -> R.ubox)
     | Tuple of (R.ubox -> array R.ubox)
*)
     | Dispatch_method meth ->
         ti_ser_td ti (meth "ser.marshal")
     ]
;



value uvals_of_ustrs
 : array string -> array uti -> array ubox
 = fun ustrs utis ->
             Array.map2to1
               (fun str uti ->
                  let deser = get_meth_untyped "deser.marshal" uti in
                  u_app deser (ubox ti_string str)
               )
               ustrs
               utis
;


value rec ti_deser_td
 : ti 'a -> type_desc -> (string -> 'a)
 = fun ti td ->
     match td with
     [ Dispatch_method meth ->
         ti_deser_td ti (meth "deser.marshal")
     | Simple tn ->
         fun a -> marshal_deser tn a
     | Sum_type _destr constr ->
         fun s ->
           let (variant_name, ustrs) =
             marshal_deser ti#type_name s
           in
           let () = printf "ti_deser: variant_name = %S\n%!" variant_name in
           let (utis, ctr_u) =
             inner 0
             where rec inner i =
               if i = Array.length constr
               then failwith "ti_deser: bad variant name"
               else
                 let (vn, utis, ctr_u) = constr.(i) in
                 if vn = variant_name
                 then (utis, ctr_u)
                 else inner (i + 1)
           in
           let () = Array.iter (printf "ti_deser: %S\n%!") ustrs in
           let () = print_newline () in
           let uvals : array ubox =
             uvals_of_ustrs
               ustrs
               utis
           in
           uget_exn ti & ctr_u uvals

     | Record_type _
     | Lambda _ _ _
         ->
           assert False

     | Tuple _destr utis constr
         ->
           fun s ->
             let ustrs : array string = marshal_deser ti#type_name s in
             uget_exn ti & constr (uvals_of_ustrs ustrs utis)
     ]
;



value ti_add_ser_deser
 : #ti 'a -> unit
 = fun ti ->
     (
         uti_add_meth (ti :> uti) "ser.marshal" &
           ubox (ti_abs ti ti_string) &
             (ti_ser_td ti ti#type_desc)
     ;
         uti_add_meth (ti :> uti) "deser.marshal" &
           ubox (ti_abs ti_string ti) &
             (ti_deser_td ti ti#type_desc)
     )
;


value ti_ser
 : #ti 'a -> 'a -> string
 = fun ti ->
     get_meth_typed1 "ser.marshal" ti ti ti_string
;


value ti_deser
 : #ti 'a -> string -> 'a
 = fun ti ->
     get_meth_typed1 "deser.marshal" ti ti_string ti
;