open Xml
open Tdl_types
let group_tag = "tdl:group"
let item_tag = "tdl:item"
let desc_tag = "tdl:desc"
let att_title = "title"
let att_date = "date"
let att_enddate = "enddate"
let att_state = "state"
let att_id = "id"
let state_strings =
[
Done, ["done"] ;
Suspended, ["suspended"] ;
Priority_low, ["low"] ;
Priority_normal, ["normal"; ""];
Priority_high, ["high"];
]
let string_of_state s =
try List.hd (List.assoc s state_strings)
with _ -> assert false
let state_of_string =
let l = List.flatten
(List.map
(fun (s, l) -> List.map (fun str -> (str, s)) l)
state_strings
)
in
fun s ->
try List.assoc s l
with Not_found ->
failwith (Printf.sprintf "Bad state string: %s" s)
let find_ele_pred name e =
match e with
Element (e,_,_) when name = String.lowercase e -> true
| _ -> false
let map_opt f = function
None -> None
| Some v -> Some (f v)
let get_att ?(required=true) atts name =
let name = String.lowercase name in
try snd (List.find (fun (s,_) -> String.lowercase s = name) atts)
with Not_found ->
if required then raise Not_found else ""
let get_opt_att atts name =
let name = String.lowercase name in
try Some
(snd (List.find
(fun (s, _) -> String.lowercase s = name)
atts)
)
with Not_found ->
None
let get_item_desc xmls =
try
match List.find (find_ele_pred desc_tag) xmls with
Element (_,atts,[PCData s]) -> Some s
| _ -> None
with
Not_found ->
None
let rec group_of_xmls g = function
[] -> g
| (PCData _ ) :: q -> group_of_xmls g q
| (Element (e, atts, subs)) :: q ->
(
match String.lowercase e with
| s when s = group_tag ->
let group = Tdl_types.group () in
group.group_title <-
get_att ~required: false atts att_title;
group.group_id <- map_opt
int_of_string (get_opt_att atts att_id);
g.group_groups <-
g.group_groups @ [group_of_xmls group subs];
| s when s = item_tag ->
(
try
let item = Tdl_types.item () in
item.item_title <- get_att atts att_title;
item.item_date <-
Tdl_date.parse
(
try
(get_att ~required: false atts att_date)
with _ -> Tdl_date.mk_mail_date (Unix.time ())
);
item.item_enddate <-
(
try
Some (Tdl_date.parse
(get_att ~required: false atts att_enddate))
with _ -> None
);
item.item_state <-
(state_of_string
(get_att ~required:false atts att_state));
item.item_desc <- get_item_desc subs;
item.item_id <- map_opt
int_of_string (get_opt_att atts att_id);
g.group_items <- g.group_items @ [item]
with
e ->
()
)
| _ ->
()
);
group_of_xmls g q
let t_parser = XmlParser.make ()
let _ = XmlParser.prove t_parser false
let group_of_source source =
let xml = XmlParser.parse t_parser source in
match xml with
| PCData _ -> failwith "Parse error: not a group"
| Element (e, atts, subs) ->
match String.lowercase e with
s when s = group_tag ->
let group = Tdl_types.group () in
group.group_title <-
get_att ~required: false atts att_title;
group.group_id <- map_opt
int_of_string (get_opt_att atts att_id);
group_of_xmls group subs
| _ ->
failwith "Parse error: not group"
let group_of_string s =
group_of_source (XmlParser.SString s)
let group_of_file file =
group_of_source (XmlParser.SFile file)
let group_of_channel c =
group_of_source (XmlParser.SChannel c)
;;
let opt_element opt s =
match opt with
None -> []
| Some v -> [Element (s, [], [PCData v])]
let default_date_format = "%d %b %Y %T %z"
let xml_of_item i =
Element (item_tag,
(
[
att_title, i.item_title ;
att_date, Tdl_date.format ~fmt: default_date_format i.item_date;
att_state, string_of_state i.item_state ;
] @
(match i.item_enddate with
None -> []
| Some d ->
[att_enddate, Tdl_date.format ~fmt: default_date_format d]
) @
(match i.item_id with
None -> []
| Some id -> [att_id, string_of_int id]
)
),
opt_element i.item_desc desc_tag
)
let rec xml_of_group g =
let items = List.map xml_of_item g.group_items in
let groups = List.map xml_of_group g.group_groups in
Element (group_tag,
[att_title, g.group_title] @
(match g.group_id with
None -> []
| Some id -> [att_id, string_of_int id]
),
(items @ groups)
)
let print_group ?(encoding="ISO-8859-1") fmt g =
let xml = xml_of_group g in
Format.fprintf fmt "<?xml version=\"1.0\" encoding=\"%s\" ?>\n" encoding;
Format.fprintf fmt "%s" (Xml.to_string_fmt xml )