(* The wire format
   Serializers and deserializers for basic datatypes
   Generic, typed serialization and de-serialization
    based on type representations
*)

(* The wire format: essentially JSON *)
type wire_atom =
  | UInt  of int 
  | UStr  of string
type wire_t = WAtom of wire_atom 
  | WComp of wire_t list
;;

let rec show_wire = function
  | WAtom (UInt x) -> string_of_int x
  | WAtom (UStr x) -> "\"" ^ x ^ "\""
  | WComp lst      -> 
      "[" ^ String.concat "; " (List.map show_wire lst) ^ "]"
;;

show_wire (WComp [WAtom (UInt 1); WComp []]);;


(* Serialisation and de-serialization *)
type 'a partial = Err of string | Datum of 'a;;

type 'a to_wire   = 'a -> wire_t
type 'a from_wire = wire_t -> 'a partial
;;

(* serializers and de-serializers for a few standard types *)

let unit_to_wire : unit to_wire = 
  fun () -> WComp []
let unit_from_wire : unit from_wire = function
  | WComp [] -> Datum ()
  | w -> Err ("unit_from_wire: bad format: " ^ show_wire w)
;;

let int_to_wire : int to_wire = 
  fun x -> WAtom (UInt x)
let int_from_wire : int from_wire = function
  | WAtom (UInt x) -> Datum x
  | w -> Err ("int_from_wire: bad format: " ^ show_wire w)
;;

let bool_to_wire : bool to_wire = 
  fun x -> WAtom (UInt (if x then 1 else 0))
let bool_from_wire : bool from_wire = function
  | WAtom (UInt 0) -> Datum false
  | WAtom (UInt 1) -> Datum true
  | w -> Err ("bool_from_wire: bad format: " ^ show_wire w)
;;

let string_to_wire : string to_wire = 
  fun x -> WAtom (UStr x)
let string_from_wire : string from_wire = function
  | WAtom (UStr x) -> Datum x
  | w -> Err ("string_from_wire: bad format: " ^ show_wire w)
;;


let tup2_to_wire twx twy : ('a * 'b) to_wire = 
  fun (x,y) -> WComp [twx x; twy y]
let tup2_from_wire fwx fwy : ('a * 'b) from_wire = function
  | WComp [wx; wy] -> 
      (match (fwx wx, fwy wy) with
      | (Datum x, Datum y) -> Datum (x,y)
      | (Err e,_) | (_,Err e) -> Err ("tup2 reports: " ^ e))
  | w -> Err ("tup2_from_wire: bad format: " ^ show_wire w)
;;

(* Convenient wrappers for for a few popular function types *)
let fn_int_int f argw =
    match int_from_wire argw with
    | Datum x -> int_to_wire (f x)
    | Err e   -> failwith e
;;

let fn_int2_bool f argw =
  match tup2_from_wire int_from_wire int_from_wire argw with
    | Datum x -> bool_to_wire (f x)
    | Err e   -> failwith e

let fn_intint_bool f wx wy =
  match (int_from_wire wx, int_from_wire wy) with
    | (Datum x, Datum y) -> bool_to_wire (f x y)
    | (Err e,_) | (_,Err e)   -> failwith e


(* Type representation *)
type ('a,'b) eq = EQ of ('a->'b) * ('b ->'a);;
let refl = EQ ((fun x -> x), (fun x -> x));;

type 'a typerep =
  | Typ_prim of 'a from_wire * 'a to_wire
  | Typ_arrow of < m_arr : 'w. ('a,'w) arr_k -> 'w >
      (* The standard encoding of existentials *)
and ('a,'w) arr_k = 
    {arr_k : 'u 'v. (('u -> 'v),'a) eq * 'u typerep * 'v typerep -> 'w}
;;

let unit_typerep   = Typ_prim (unit_from_wire, unit_to_wire);;
let int_typerep    = Typ_prim (int_from_wire, int_to_wire);;
let bool_typerep   = Typ_prim (bool_from_wire, bool_to_wire);;
let string_typerep = Typ_prim (string_from_wire, string_to_wire);;
let arr_typerep arg res = 
  Typ_arrow (object method m_arr : 'w. ('a,'w) arr_k -> 'w
      = fun k -> k.arr_k (refl, arg, res) end)
;;

let tup2_typerep x y = 
  match (x,y) with
  | (Typ_prim (fwx,twx), Typ_prim (fwy,twy)) ->
      Typ_prim (tup2_from_wire fwx fwy, tup2_to_wire twx twy)
  | _ -> failwith "Tuples of function types are not allowed"
;;

let stringint = arr_typerep string_typerep int_typerep;;

(* Need injectivity *)
let arrow_result : ('a->'b) typerep -> 'b typerep = function
    Typ_arrow x -> x#m_arr {arr_k = fun (_,_,r) -> Obj.magic r}
;;

(* Embedding-projection between a user-defined datatype 'a
   and another type 'b, typically a sum-of-products view *)
type ('a,'b) iso = {iso_ab : 'a -> 'b; iso_ba : 'b -> 'a partial};;

let user_typerep iso btyperep =
  match btyperep with
  | Typ_prim (bfrom,bto) ->
      Typ_prim ((fun w -> match bfrom w with
                          | Datum x -> iso.iso_ba x
			  | Err e   -> Err e),
		(fun x -> bto (iso.iso_ab x)))
  | _ -> failwith "User datatypes of function types are not allowed"
;;


(* Generic, typed serialization and de-serialization *)

let gen_to_wire typerep x = match typerep with
  | Typ_prim (from_wire,to_wire) -> to_wire x
  | _ -> failwith "Only primitive types can be communicated"

let gen_from_wire typerep w = match typerep with
  | Typ_prim (from_wire,to_wire) -> from_wire w
  | _ -> failwith "Only primitive types can be communicated"