cadastr / src / cd_Json.ml

open Cd_All; open Cdt;

module Jt = Json_type;
module Bl = Jt.Build;
module Br = Jt.Browse;

open Strings.Latin1;

value ti_json_t = ((new ti_simple "Json_type.t") :> ti Jt.t)
;

value ti_json_to ti_a = ti_abs (ti_a :> tti _) ti_json_t
;

value ti_json_from ti_a = ti_abs ti_json_t (ti_a :> tti _)
;

value ubox_to_json
 : ubox -> Jt.t
 = fun u ->
     let uti = u.ub_uti in
     uget_exn ti_json_t &
       u_app (get_meth_untyped "json.to" uti) u
;

value ubox_from_json
 : #uti -> Jt.t -> ubox
 = fun uti j ->
     u_app (get_meth_untyped "json.from" uti) (ubox ti_json_t j)
;



value to_json_struc
 : #ti 'a -> (ubox -> ubox)  (* a -> Json_type.t *)
 = fun ti ->
  let rec to_json_td ti td =
    match td with
    [ Simple tn ->
        failwith "can't infer structural 'json.to' for \
                  simple type %s" tn
    | Sum_type destr _constr ->
        fun u ->
          let (vname, disp) = destr u in
          let uarr = disp "json.to" in
          let jargs = Array.map_to_list ubox_to_json uarr
          in
          let vname = String.lowercase vname in
          let vname = String.chop_prefix ~string:vname ~prefix:"`" in
          ubox ti_json_t (Bl.array [Bl.string vname :: jargs])

    | Record_type _ _ _ _
        -> failwith "json.to: Record_type: not implemented"

    | Tuple _ _ _
        -> failwith "json.to: Tuple: not implemented"

    | Lambda _ _ _
        -> failwith "can't convert Lambda to json"

    | Dispatch_method dm -> to_json_td ti (dm "json.to")
    ]

  in
    to_json_td ti ti#type_desc
;


value from_json_struc
 : #uti -> Jt.t -> ubox
 = fun uti ->
     let rec from_json_td uti td =
       match td with
       [ Simple tn ->
           failwith "can't infer structural 'json.from' for \
                     simple type %s" tn

       | Record_type _destr utis fields constr ->
           fun j ->
           let jlst = Br.objekt j in
           let ufields = Array.map2to1
             (fun field_uti field_name ->
                let open Cd_List in
                match List.Assoc.get_opt
                        ~keq:String.eq field_name jlst
                with
                [ None -> failwith
                    "Cd_Json.from_json_struc: field %S not found in json"
                    field_name
                | Some field_json ->
                    ubox_from_json field_uti field_json
                ]
             )
             utis
             fields
           in
           constr ufields

       | Sum_type _destr _constr
           -> failwith "json.from: Sum_type: not implemented"
           
       | Tuple _destr utis constr ->
           fun j ->
           let jarr = Array.of_list (Br.array j) in
           let ufields = Array.map2to1
             (fun field_uti field_json ->
                ubox_from_json field_uti field_json
             )
             utis
             jarr
           in
           constr ufields

       | Lambda _ _ _
           -> failwith "can't convert json to Lambda"

       | Dispatch_method dm -> from_json_td uti (dm "json.from")

       ]
     in
       from_json_td uti uti#type_desc
;


(* should add to and from methods both. *)
value rec ti_add_json
 : #ti 'a
   -> ?json_to:('a -> Jt.t)
   -> ?json_from:(Jt.t -> 'a)
   -> unit -> unit
 = fun ti ?json_to ?json_from () ->
     let json_to : 'a -> Jt.t =
       match json_to with
       [ None -> fun a -> uget_exn ti_json_t (to_json_struc ti (ubox ti a))
       | Some m -> m
       ]
     in
     let u_json_to_meth = ubox (ti_json_to ti) json_to
     in
     let json_from =
       match json_from with
       [ None ->
           fun j -> uget_exn ti (from_json_struc ti j)
       | Some m -> m
       ]
     in
     let u_json_from_meth = ubox (ti_json_from ti) json_from
     in
       ( uti_add_meth ti "json.to" u_json_to_meth
       ; uti_add_meth ti "json.from" u_json_from_meth
       ; Cd_Ser.ti_gen_add_ser ti "json"
           (fun a ->
              let j = json_to a
              and b = Buffer.create 80 in
              let () = Json_io.Fast.print
                ~recursive:True ~allow_nan:True b j in
              Buffer.contents b
           )
       ; Cd_Ser.ti_gen_add_deser ti "json"
           (json_from %<
            Json_io.json_of_string
              ~allow_comments:True
              ~allow_nan:True
              ~big_int_mode:True
              ~recursive:True
           )
       )
   ;

(* standard types: *)

value () =
  ( ti_add_json (ti_string :> ti _)
     ~json_to:Bl.string
     ~json_from:Br.string
     ()
  )
;


(* использование: *)

value to_json
 : #ti 'a -> 'a -> Jt.t
 = fun ti a ->
     ubox_to_json (ubox ti a)
;


value from_json
 : #ti 'a -> Jt.t -> 'a
 = fun ti_a j ->
     uget_exn ti_a & ubox_from_json ti_a j
;


(* todo: сделать нормальные параметризованные типы блеять *)
value ti_list_add_json
 : #ti (list 'a) -> #ti 'a -> unit
 = fun ti_list_a ti_a ->
   (
     uti_add_meth ti_list_a "json.from" &
     ubox (ti_json_from ti_list_a) &
     list_of_json
     where list_of_json j =
       let j_list = Br.array j in
       let a_list = List.map (from_json ti_a) j_list in
       a_list
   ;
     uti_add_meth ti_list_a "json.to" &
     ubox (ti_json_to ti_list_a) &
     list_to_json
     where list_to_json lst =
       Bl.array & List.map (to_json ti_a) lst
   )
;


(* add "json.{from,to}" for option type, assuming that json "null"
   is [None] and any other value is [Some _]
 *)

value ti_option_add_json_null
 : #ti (option 'a) -> #ti 'a -> unit
 = fun ti_option_a ti_a ->
   (
     uti_add_meth ti_option_a "json.from" &
     ubox (ti_json_from ti_option_a) &
     option_of_json
     where option_of_json j =
       if Br.is_null j
       then None
       else Some (from_json ti_a j)
   ;
     uti_add_meth ti_option_a "json.to" &
     ubox (ti_json_to ti_option_a) &
     option_to_json
     where option_to_json opt_a =
       match opt_a with
       [ None -> Bl.null
       | Some a -> to_json ti_a a
       ]
   )
;




(*

value run () = ()  (* Printf.eprintf "Cd_Json loaded.\n%!" *)
  (* init here *)
;

value init =
  let run_res = lazy (run ()) in
  fun () -> Lazy.force run_res
;

*)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.