1. Dmitry Grebeniuk
  2. cadastr

Source

cadastr / src / cd_Ds.ml

(* support for "dumbstreaming" protocol *)

open Cd_All; open Cdt;


(* list of lists, recursive *)
type lol =
  [ One of string
  | Lst of list lol
  ]
;

value ti_lol : #ti lol = new ti_simple "Cd_Ds.lol"
;


value ubox_to_lol
 : ubox -> lol
 = fun u ->
     let uti = u.ub_uti in
     uget_exn ti_lol &
       u_app (get_meth_untyped "ds.to" uti) u
;


value sort_record_destr
 : array (field_name * ubox) -> unit
 = fun arr ->
     Array.sort
       (fun (f1, _) (f2, _) -> Pervasives.compare f1 f2)
       arr
;


value rec ds_ser_struc
 : #uti -> ubox -> lol
 = fun uti u ->
     ds_ser_struc_td uti#type_desc u

and ds_ser_struc_td
 : type_desc -> ubox -> lol
 = fun td ->
     match td with
     [ Simple tn ->
        failwith "can't infer structural 'ds.to' for \
                  simple type %s" tn
     | Sum_type destr _constr -> fun u ->
         let (vname, disp) = destr u in
         let uarr = disp "ds.to" in
         Lst
           [  One vname
           :: Array.map_to_list ubox_to_lol uarr
           ]
     | Record_type destr _utis _fields _constr -> fun u ->
         let uarr = destr u in
         let () = sort_record_destr uarr in
         Lst (Array.map_to_list (snd @> ubox_to_lol) uarr)
    | Tuple destr _utis _constr -> fun u ->
         let uarr = destr u in
         Lst (Array.map_to_list ubox_to_lol uarr)
     | Lambda _ _ _ ->
         failwith "can't serialize Lambda to dumbstreaming"
     | Dispatch_method dm ->
         ds_ser_struc_td (dm "ds.to")
     ]
;


type ds_reader 'a =
  [ Dr_cont of (string -> ds_reader 'a)
  | Dr_ret of 'a
  ]
;

value rec ds_rmap
 : ! 'a 'b . ('a -> 'b) -> ds_reader 'a -> ds_reader 'b
 = fun f dr ->
     match dr with
     [ Dr_cont reader -> Dr_cont (fun s -> ds_rmap f (reader s))
     | Dr_ret res -> Dr_ret (f res)
     ]
;


(*
value rec ds_run_list
 : ds_reader 'a -> list string -> ('a * list string)
 = fun r lst ->

     match r with
     [ Dr_ret x -> (x, lst)
     | Dr_cont f ->
         match lst with
         [ [] -> failwith "underflow"
         | [h :: t] -> ds_run_list (f h) t
         ]
     ]

;
*)


value ds_ret x = Dr_ret x;
value ds_read f = Dr_cont f;


module Bs = Cd_Array.Array.BuildSized;


value ds_array_map_seq
 : ('a -> ds_reader 'b) -> array 'a -> ds_reader (array 'b)
 = fun (type a) (type b) (fr : a -> ds_reader b) arr ->
   let len = Array.length arr in
   let bld = Bs.create ~size:len in
   loop 0
   where rec loop i : ds_reader (array b) =
     if i = len
     then
       ds_ret & Bs.get bld
     else
       let b_rd = fr arr.(i) in
       (match inner b_rd with
        [ Dr_cont _ -> assert False
        | Dr_ret x -> (Bs.add x bld; loop (i + 1))
        ]
       )
       where rec inner r : ds_reader b =
         match r with
         [ Dr_ret _ as x -> x
         | Dr_cont f -> ds_read & fun s -> inner (f s)
         ]
;


value ds_array_iter_seq
 : ('a -> ds_reader unit) -> array 'a -> ds_reader unit
 = fun (type a) (fr : a -> ds_reader unit) arr ->
   let len = Array.length arr in
   loop 0
   where rec loop i : ds_reader unit =
     if i = len
     then
       ds_ret ()
     else
       let u_rd = fr arr.(i) in
       (match inner u_rd with
        [ Dr_cont _ -> assert False
        | Dr_ret () -> loop (i + 1)
        ]
       )
       where rec inner r : ds_reader unit =
         match r with
         [ Dr_ret () -> r
         | Dr_cont f -> ds_read & fun s -> inner (f s)
         ]
;


value ti_array_int = new Array.ti ti_int ()
;

value record_fields_order =
let mn = "ds.record_fields_order" in
fun uti fields ->
  try
    get_meth_typed0 mn uti ti_array_int
  with
  [ No _ ->
     let a = Array.mapi (fun i n -> (n, i)) fields in
     let () = Array.fast_sort (fun (n1, _) (n2, _) -> compare n1 n2) a in
     (* b;c;a -> a2;b0;c1 *)
     let r = Array.map snd a in
     ( uti_add_meth uti mn (ubox ti_array_int r)
     ; r
     )
  ]
;

module R = Array.BuildSizedRandAcc
;

value rec ds_deser_struc
 : #uti -> ds_reader ubox
 = fun uti ->
     ds_deser_struc_td uti uti#type_desc

and ds_deser_struc_td
 : #uti -> type_desc -> ds_reader ubox
 = fun uti td ->
     match td with
     [ Simple tn ->
        failwith "can't infer structural 'ds.from' for \
                  simple type %s" tn
     | Sum_type _destr constr ->
         ds_read & fun ds_vname ->
         let constr_len = Array.length constr in
         loop 0
         where rec loop i =
           if i = constr_len
           then failwith "can't find constructor %S for sum type %S"
                  ds_vname uti#type_name
           else
             let (vname, utis, do_constr) = constr.(i) in
             if vname <> ds_vname
             then
               loop (i + 1)
             else
               ds_rmap
                 do_constr
                 (ds_array_map_seq ds_deser_struc utis)

     | Record_type _destr utis fields constr ->
         let n = Array.length fields in
         let ord = record_fields_order uti fields in
         let vals = R.create ~size:n in
         let i = ref 0 in
         ds_rmap
           (fun () ->
              constr & R.get vals
           )
           (ds_array_iter_seq
              (fun uti ->
                 ds_rmap
                   (fun v ->
                      ( R.set vals ord.(i.val) v
                      ; incr i
                      )
                   )
                   (ds_deser_struc uti)
              )
              utis
           )

    | Tuple _destr utis constr ->
         ds_rmap
           (fun arr -> constr arr)
           (ds_array_map_seq ds_deser_struc utis)

     | Lambda _ _ _ ->
         failwith "can't deserialize Lambda from dumbstreaming"

     | Dispatch_method dm ->
         ds_deser_struc_td uti (dm "ds.from")
     ]
;