1. Dmitry Grebeniuk
  2. cadastr

Commits

Dmitry Grebeniuk  committed 3b3f923

+ some json

  • Participants
  • Parent commits e6c3b41
  • Branches default

Comments (0)

Files changed (1)

File src/cd_Json.ml

View file
  • Ignore whitespace
-module Cdj
- =
-  struct
+open Cd_All; open Cdt;
 
-    open Cd_All; open Cdt;
+module Jt = Json_type;
+module Bl = Jt.Build;
+module Br = Jt.Browse;
 
-    module Jt = Json_type;
-    module Bl = Jt.Build;
-    module Br = Jt.Browse;
+open Strings.Latin1;
 
-    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 ti_json_t
-    ;
-
-    value ti_json_from ti_a = ti_abs ti_json_t ti_a
-    ;
-
-    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 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 ->
-            fun _u ->
-              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
-    ;
-
-
-
-    (* 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 a -> uget_exn ti (from_json_struc *) failwith "not impl"
-           | 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
-           )
-       ;
-
-    (* 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 &
-           u_app (get_meth_untyped "json.from" ti_a) (ubox ti_json_t 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
-    ;
-
-
-
-
-
-    (* *)
-
-    value run () = ()  (* Printf.eprintf "Cd_Json loaded.\n%!" *)
-      (* init here *)
-    ;
-
-    value init =
-      let run_res = lazy (run ()) in
-      fun () -> Lazy.force run_res
-    ;
-
-
-  end
+value ti_json_t = ((new ti_simple "Json_type.t") :> ti Jt.t)
 ;
 
+value ti_json_to ti_a = ti_abs ti_a ti_json_t
+;
+
+value ti_json_from ti_a = ti_abs ti_json_t ti_a
+;
+
+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 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 ->
+        fun _u ->
+          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
+;
+
+
+
+(* 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 a -> uget_exn ti (from_json_struc *) failwith "not impl"
+       | 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
+       )
+   ;
+
+(* 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 &
+       u_app (get_meth_untyped "json.from" ti_a) (ubox ti_json_t 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
+;
+
+
+
+
+
+(* *)
+
+value run () = ()  (* Printf.eprintf "Cd_Json loaded.\n%!" *)
+  (* init here *)
+;
+
+value init =
+  let run_res = lazy (run ()) in
+  fun () -> Lazy.force run_res
+;