(*********************************************************************************)

(*                Cameleon                                                       *)
(*                                                                               *)
(*    Copyright (C) 2005,2006 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Library General Public License as            *)
(*    published by the Free Software Foundation; either version 2 of the         *)
(*    License, or  any later version.                                            *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
(*    GNU Library General Public License for more details.                       *)
(*                                                                               *)
(*    You should have received a copy of the GNU Library General Public          *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)


(* $Id: tdl_io.ml,v 1.2 2004/03/20 23:05:57 zoggy Exp $ *)

open Xml
open Tdl_types

(** Parsing/Printing TDL documents. *)


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"

(* How to represent each state; the first string associated
  to each state is the string used for printing. *)

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)

(**

Parsing

*)


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)
;;

(**

Printing

*)


let opt_element opt s =
  match opt with
    None -> []
  | Some v -> [Element (s, [], [PCData v])]

let default_date_format = "%d %b %Y %T %z"
    (* ex: 19 May 2002 15:21:36 *)

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 )