243 lines
7.3 KiB
OCaml
243 lines
7.3 KiB
OCaml
open Def
|
|
|
|
module type ConverterDriver = sig
|
|
type t
|
|
|
|
val str : string -> t
|
|
val int : int -> t
|
|
val obj : (string * t) array -> t
|
|
val null : t
|
|
val array : 't array -> t
|
|
val list : 't list -> t
|
|
val bool : bool -> t
|
|
end
|
|
|
|
(* e.g. js_of_ocaml *)
|
|
(* module ConverterDriver = struct
|
|
* type t = Js.Unsafe.any
|
|
* let str x = Js.Unsafe.inject @@ Js.string x
|
|
* let int x = Js.Unsafe.inject x
|
|
* let obj x = Js.Unsafe.inject @@ Js.Unsafe.obj x
|
|
* let null = Js.Unsafe.inject Js.null
|
|
* let array x = Js.Unsafe.inject @@ Js.array x
|
|
* let list x = array (Array.of_list x)
|
|
* let bool x = Js.Unsafe.inject @@ if x then Js._true else Js._false
|
|
* end *)
|
|
|
|
(* e.g. yojson *)
|
|
(* module ConverterDriver = struct
|
|
* type t = Yojson.Basic.t
|
|
* let str x = `String x
|
|
* let int x = `Int x
|
|
* let obj x = `Assoc x
|
|
* let null = `Null
|
|
* let array x = `List (Array.to_list x)
|
|
* let list x = `List x
|
|
* let bool x = `Bool x
|
|
* end *)
|
|
|
|
module Make (D : ConverterDriver) = struct
|
|
let str = D.str
|
|
let int = D.int
|
|
let obj = D.obj
|
|
let null = D.null
|
|
let array = D.array
|
|
let list = D.list
|
|
let bool = D.bool
|
|
let opt fn = function Some x -> fn x | None -> null
|
|
|
|
(** gwdb to json *)
|
|
|
|
let conv_dmy dmy =
|
|
obj
|
|
[|
|
|
("day", int dmy.day);
|
|
("delta", if dmy.delta = 0 then null else int dmy.delta);
|
|
("month", int dmy.month);
|
|
("year", int dmy.year);
|
|
|]
|
|
|
|
let conv_dmy2 dmy =
|
|
obj
|
|
[|
|
|
("day", int dmy.day2); ("month", int dmy.month2); ("year", int dmy.year2);
|
|
|]
|
|
|
|
let conv_date_cal dt cal =
|
|
let prec =
|
|
match dt.prec with
|
|
| Sure -> str "Sure"
|
|
| About -> str "About"
|
|
| Maybe -> str "Maybe"
|
|
| Before -> str "Before"
|
|
| After -> str "After"
|
|
| OrYear _ -> str "OrYear"
|
|
| YearInt _ -> str "YearInt"
|
|
in
|
|
let dmy2 =
|
|
match dt.prec with
|
|
| OrYear dmy2 -> conv_dmy2 dmy2
|
|
| YearInt dmy2 -> conv_dmy2 dmy2
|
|
| _ -> null
|
|
in
|
|
obj
|
|
[|
|
|
("prec", prec);
|
|
("dmy1", conv_dmy dt);
|
|
("dmy2", dmy2);
|
|
("calendar", str cal);
|
|
|]
|
|
|
|
let conv_date oc =
|
|
match oc with
|
|
| Dgreg (d, c) -> conv_date_cal d (Def_show.show_calendar c)
|
|
| Dtext t -> str t
|
|
|
|
let conv_cdate cd =
|
|
match Date.od_of_cdate cd with None -> null | Some date -> conv_date date
|
|
|
|
let conv_pevent_name x =
|
|
str
|
|
@@ Def_show.show_gen_pers_event_name
|
|
(fun fmt -> Format.fprintf fmt "Epers_Name %s")
|
|
x
|
|
|
|
let conv_event_witness_kind x = str @@ Def_show.show_witness_kind x
|
|
let handler_of_iper i = str @@ Gwdb_driver.string_of_iper i
|
|
let handler_of_ifam i = str @@ Gwdb_driver.string_of_ifam i
|
|
|
|
let conv_event_witness (i, kind) =
|
|
obj
|
|
[|
|
|
("person", handler_of_iper i); ("kind", conv_event_witness_kind kind);
|
|
|]
|
|
|
|
let conv_pevent pevent =
|
|
obj
|
|
[|
|
|
("place", str pevent.epers_place);
|
|
("reason", str pevent.epers_reason);
|
|
("note", str pevent.epers_note);
|
|
("src", str pevent.epers_src);
|
|
("name", conv_pevent_name pevent.epers_name);
|
|
("date", conv_cdate pevent.epers_date);
|
|
( "witnesses",
|
|
array @@ Array.map conv_event_witness pevent.epers_witnesses );
|
|
|]
|
|
|
|
let conv_title_name = function
|
|
| Tmain -> str ""
|
|
| Tname s -> str s
|
|
| Tnone -> null
|
|
|
|
let conv_title gen_title =
|
|
obj
|
|
[|
|
|
("name", conv_title_name gen_title.t_name);
|
|
("date_start", conv_cdate gen_title.t_date_start);
|
|
("date_end", conv_cdate gen_title.t_date_end);
|
|
("nth", int gen_title.t_nth);
|
|
("ident", str gen_title.t_ident);
|
|
("place", str gen_title.t_place);
|
|
|]
|
|
|
|
let conv_relation_kind x = str @@ Def_show.show_relation_kind x
|
|
|
|
let conv_fevent_name x =
|
|
str
|
|
@@ Def_show.show_gen_fam_event_name
|
|
(fun fmt -> Format.fprintf fmt "Efam_Name %s")
|
|
x
|
|
|
|
let conv_fevent fevent =
|
|
obj
|
|
[|
|
|
("date", conv_cdate fevent.efam_date);
|
|
("name", conv_fevent_name fevent.efam_name);
|
|
("note", str fevent.efam_note);
|
|
("place", str fevent.efam_place);
|
|
("reason", str fevent.efam_reason);
|
|
("src", str fevent.efam_src);
|
|
( "witnesses",
|
|
array @@ Array.map conv_event_witness fevent.efam_witnesses );
|
|
|]
|
|
|
|
let conv_divorce = function
|
|
| NotDivorced -> bool false
|
|
| Divorced date -> conv_cdate date
|
|
| Separated -> bool true
|
|
|
|
let conv_relation_type x = str @@ Def_show.show_relation_type x
|
|
|
|
let conv_rparent gen_relation =
|
|
obj
|
|
[|
|
|
("father", opt handler_of_iper gen_relation.r_fath);
|
|
("mother", opt handler_of_iper gen_relation.r_moth);
|
|
("source", str gen_relation.r_sources);
|
|
("type", conv_relation_type gen_relation.r_type);
|
|
|]
|
|
|
|
let conv_death = function
|
|
| Def.NotDead -> str "NotDead"
|
|
| Death (Killed, _) -> str "Killed"
|
|
| Death (Murdered, _) -> str "Murdered"
|
|
| Death (Executed, _) -> str "Executed"
|
|
| Death (Disappeared, _) -> str "Disappeared"
|
|
| Death (Unspecified, _) -> str "Unspecified"
|
|
| DeadYoung -> str "DeadYoung"
|
|
| DeadDontKnowWhen -> str "DeadDontKnowWhen"
|
|
| DontKnowIfDead -> str "DontKnowIfDead"
|
|
| OfCourseDead -> str "OfCourseDead"
|
|
|
|
let conv_person base p =
|
|
let pp = Gwdb.gen_person_of_person p in
|
|
let pp = Futil.map_person_ps (fun i -> i) (Gwdb.sou base) pp in
|
|
let pa = Gwdb.gen_ascend_of_person p in
|
|
let pu = Gwdb.gen_union_of_person p in
|
|
obj
|
|
[|
|
|
( "access",
|
|
int (match pp.access with Private -> 2 | Public -> 1 | _ -> 0) );
|
|
("aliases", list (List.map str pp.aliases));
|
|
("first_names_aliases", list (List.map str pp.first_names_aliases));
|
|
("firstname", str pp.first_name);
|
|
("image", str pp.image);
|
|
("iper", handler_of_iper pp.key_index);
|
|
("lastname", str pp.surname);
|
|
("note", str pp.notes);
|
|
("occ", int pp.occ);
|
|
("occupation", str pp.occupation);
|
|
("parents", opt handler_of_ifam pa.parents);
|
|
( "consang",
|
|
if pa.consang = Adef.no_consang then null
|
|
else int (Adef.fix_repr pa.consang) );
|
|
("pevents", list (List.map conv_pevent pp.pevents));
|
|
("psources", str pp.psources);
|
|
("public_name", str pp.public_name);
|
|
("qualifiers", list (List.map str pp.qualifiers));
|
|
("related", list (List.map handler_of_iper pp.related));
|
|
("rparents", list (List.map conv_rparent pp.rparents));
|
|
("sex", int (match pp.sex with Male -> 1 | Female -> 2 | _ -> 0));
|
|
("surnames_aliases", list (List.map str pp.surnames_aliases));
|
|
("titles", list (List.map conv_title pp.titles));
|
|
("unions", list (List.map handler_of_ifam (Array.to_list pu.family)));
|
|
|]
|
|
|
|
let conv_family base f =
|
|
let ff = Gwdb.gen_family_of_family f in
|
|
let ff = Futil.map_family_ps (fun i -> i) (fun i -> i) (Gwdb.sou base) ff in
|
|
let fc = Gwdb.gen_couple_of_family f in
|
|
let fd = Gwdb.gen_descend_of_family f in
|
|
obj
|
|
[|
|
|
("fevents", list (List.map conv_fevent ff.fevents));
|
|
("comment", str ff.comment);
|
|
("origin_file", str ff.origin_file);
|
|
("fsources", str ff.fsources);
|
|
("witnesses", array (Array.map handler_of_iper ff.witnesses));
|
|
("children", array (Array.map handler_of_iper fd.children));
|
|
("parents", array (Array.map handler_of_iper @@ Adef.parent_array fc));
|
|
|]
|
|
end
|