(* copyright 2004 Serge LEBLANC *)
(* this software is under GNU GPL *)

type Xml_version = [ '0'--'9'+ ('.' '0'--'9'+)* ] ;;
type Xml_int = [ '0'--'9'+ ] ;;
type Xml_id = Xml_int ;; 
type Xml_kind = "individual" | "delegate" ;;
type Xml_login = <login>Latin1 ;;
type Xml_password = <password>Latin1 ;;
type Xml_group = <group>Latin1 ;;
type Xml_participant = <participant p_id=Xml_id kind=Xml_kind>[ Xml_login Xml_password Xml_group+ ] ;;
type Xml_participant_base = <participant_base>[ Xml_participant* ] ;;
type Xml_tag = <tag t_id=Xml_id>Latin1 ;;
type Xml_classification_base = <classification_base>[ Xml_tag* ] ;;
type Xml_description = <description>Latin1 ;;
type Xml_author = <author>Latin1 ;;
type Xml_limit_date = <limit_date>Latin1 ;;
type Xml_link = <link>Latin1 ;;
type Xml_vote = <vote voter=Xml_id>[ <choice is=Xml_int>[]* ] ;;
type Xml_elected = <elected>Xml_int ;;
type Xml_response = <response r_id=Xml_id>[ Xml_description Xml_author Xml_link* ] ;;
type Xml_question = <question q_id=Xml_id>[ Xml_description Xml_author Xml_limit_date Xml_response* Xml_vote* Xml_elected* ] ;;
type Xml_question_base = <question_base>[ Xml_question* ] ;;

type Xml_demexp_base = <demexp_base version=Xml_version>[ Xml_participant_base Xml_classification_base Xml_question_base ] ;;

type Ocaml_int = -1073741824 -- 1073741823 ;;
type Ocaml_string = Latin1 ;;
type Ocaml_kind = `Individual | `Delegate ;;
type Ocaml_participant = {| kind=Ocaml_kind; login=Ocaml_string; password=Ocaml_string; groups=[ Ocaml_string* ] |} ;;
(* type Ocaml_option_string = `None | (`Some,Ocaml_string) ;; *)
type Ocaml_response = {| r_id=Ocaml_int; r_desc=Ocaml_string; r_author=Ocaml_string; r_links=[ Ocaml_string* ] |} ;;
type Ocaml_vote = {| voter=Ocaml_int; choices=[ Ocaml_int* ] |} ;;
type Ocaml_elected = Ocaml_int ;;
type Ocaml_tag = Ocaml_string ;;
type Ocaml_question = {| q_desc=Ocaml_string; q_author=Ocaml_string; limit_date=Ocaml_string; responses=[ Ocaml_response* ]; votes=[ Ocaml_vote* ]; elected=[ Ocaml_elected* ] |} ;;

type Ocaml_xml_content={| version=Ocaml_string; participants=[ (Ocaml_int,Ocaml_participant)* ]; tags=[ (Ocaml_int,Ocaml_tag)* ]; questions=[ (Ocaml_int,Ocaml_question)* ] |} ;;


(* xml->ocaml transformation functions *)

let trans_xml_participants (p : [ Xml_participant* ]) : [ (Ocaml_int,Ocaml_participant)* ] =
  let trans_kind (Xml_kind -> Ocaml_kind)
    | "individual" -> `Individual
    | "delegate" -> `Delegate in
  map p with
    <participant p_id=i kind=k>[ <login>l <password>p; g ] -> match (int_of i) with
      | x&Ocaml_int -> (x, { kind=(trans_kind k); login=l; password=p; groups=(map g with <group>s -> s) })
      | _ -> raise "Invalid p_id value"
  ;;

let trans_xml_tags (t : [ Xml_tag* ]) : [ (Ocaml_int,Ocaml_string)* ] =
  map t with
    <tag t_id=i>s -> match (int_of i) with
      | x&Ocaml_int -> (x,s)
      | _ -> raise "Invalid t_id value"
  ;;

let trans_xml_questions (q : [ Xml_question* ]) : [ (Ocaml_int, Ocaml_question)* ] =
  let trans_response (r : [ Xml_response* ]) : [ Ocaml_response* ] =
    map r with
      <response r_id=i>[ <description>d <author>a l::Xml_link* ] -> match (int_of i) with
      | x&Ocaml_int -> { r_id=x; r_desc=d; r_author=a; r_links=(map l with <link>s -> s) }
      | _ -> raise "Invalid r_id value" in
  let trans_vote (v : [ Xml_vote* ]) : [ Ocaml_vote* ] = 
    map v with
      <vote voter=i>s -> match (int_of i) with
        | x&Ocaml_int -> { voter=x; choices=(map s with <choice is=i>[] -> match (int_of i) with 
          | x&Ocaml_int -> x
          | _ -> raise "Invalid choice value" ) }
        | _ -> raise "Invalid voter element" in
  let trans_elected (e : [ Xml_elected* ]) : [ Ocaml_elected* ] =
     map e with
      <elected>i -> match (int_of i) with
        | x&Ocaml_int -> x
        | _ -> raise "Invalid elected value" in
  map q with
    <question q_id=i>[ <description>d <author>a <limit_date>l r::Xml_response* v::Xml_vote* e::Xml_elected* ] -> match (int_of i) with
      | x&Ocaml_int -> (x, { q_desc=d; q_author=a; limit_date=l; responses=(trans_response r); votes=(trans_vote v); elected=(trans_elected e) })
      | _ -> raise "Invalid q_id value"
  ;;


(* load functions *)

let load_xml_demexp_participants (f : Latin1) : [ (Ocaml_int,Ocaml_participant)* ] =
  let d : Xml_demexp_base = match load_xml f with
    | x&Xml_demexp_base -> x
    | _ -> raise "Not a Demexp document" in
  trans_xml_participants ([d]/Xml_participant_base/Xml_participant)
  ;;

let load_xml_demexp_tags (f : Latin1) : [ (Ocaml_int,Ocaml_string)* ] =
  let d : Xml_demexp_base = match load_xml f with
    | x&Xml_demexp_base -> x
    | _ -> raise "Not a Demexp document" in
  trans_xml_tags ([d]/Xml_classification_base/Xml_tag)
  ;;

let load_xml_demexp_questions (f : Latin1) : [ (Ocaml_int,Ocaml_question)* ] =
  let d : Xml_demexp_base = match load_xml f with
    | x&Xml_demexp_base -> x
    | _ -> raise "Not a Demexp document" in
  trans_xml_questions ([d]/Xml_question_base/Xml_question) 
  ;;
 
let load_xml_demexp (f : Latin1) : Ocaml_xml_content =
  let d : Xml_demexp_base = match load_xml f with
    | x&Xml_demexp_base -> x
    | _ -> raise "Not a Demexp document" in
  { version=(match d with <demexp_base version=v>_ -> v);
    participants=(trans_xml_participants ([d]/Xml_participant_base/Xml_participant));
    tags=(trans_xml_tags ([d]/Xml_classification_base/Xml_tag));
    questions=(trans_xml_questions ([d]/Xml_question_base/Xml_question)) }    
  ;;

(* ocaml->xml transformation functions *)

let trans_ocaml_int (i : Ocaml_int) : Xml_int =
  let s = string_of i in
    match s with
        x&Xml_int -> x
      | _ -> raise ("unvalid id : " @ s)  

let trans_ocaml_participants (a : [(Ocaml_int,Ocaml_participant)*]) : [Xml_participant*] =
  let trans_groups ([ Ocaml_string* ] -> [ Xml_group+ ])
      g&[Ocaml_string+] -> (map g with s&Latin1 -> <group>s)
    | [] -> raise "inadmissible empty participant groups"
  in
    let trans_kind (Ocaml_kind -> Xml_kind)
      | `Individual -> "individual"
      | `Delegate -> "delegate"
    in
      map a with
        (i,{| kind=q; login=l; password=p; groups=g |}) -> <participant kind=(trans_kind q) p_id=(trans_ocaml_int i)>[ <login>l <password>p !(trans_groups g) ]
  ;;

let trans_ocaml_tags (a : [(Ocaml_int,Ocaml_string)*]) : [Xml_tag*] =
   map a with (i,s) -> <tag t_id=(trans_ocaml_int i)>s
  ;;  

let trans_ocaml_questions (a : [(Ocaml_int,Ocaml_question)*]) : [Xml_question*] =
  let trans_responses (r : [Ocaml_response*]) : [Xml_response*] =
    let trans_links (l : [Ocaml_string*]) : [Xml_link*] =
      map l with s&Latin1 -> <link>s
    in
      map r with
          {| r_id=i; r_desc=d; r_author=a; r_links=l |} -> <response r_id=(trans_ocaml_int i)>[ <description>d <author>a !(trans_links l) ] 
        (* | {| r_id=i; r_desc=d; r_author=a |} -> <response r_id=(trans_ocaml_int i)>[ <description>d <author>a ] *)
  in
    let trans_votes (v : [Ocaml_vote*]) : [Xml_vote*] =
      map v with {| voter=i; choices=c |} -> <vote voter=(trans_ocaml_int i)>(map c with i&Int -> <choice is=(trans_ocaml_int i)>[])
    in
      let trans_elected (e : [Ocaml_elected*]) : [Xml_elected*] =
        map e with i&Int -> <elected>(trans_ocaml_int i)
      in 
        map a with
          (i,{| q_desc=d; q_author=a; limit_date=l; responses=r; votes=v; elected=e |}) -> <question q_id=(trans_ocaml_int i)>[ <description>d <author>a <limit_date>l !(trans_responses r) !(trans_votes v) !(trans_elected e) ]
  ;;


let save_xml_demexp_participants (f : Latin1)(a : [ (Ocaml_int,Ocaml_participant)* ]) : [] =
   dump_to_file_utf8 f (print_xml_utf8 <participant_base>(trans_ocaml_participants a)) ;;

let save_xml_demexp_tags (f : Latin1)(a : [ (Ocaml_int,Ocaml_string)* ]) : [] =
  dump_to_file_utf8 f (print_xml_utf8 <classification_base>(trans_ocaml_tags a)) ;;

let save_xml_demexp_questions (f : Latin1)(a : [ (Ocaml_int,Ocaml_question)* ]) : [] =
  dump_to_file_utf8 f (print_xml_utf8 <question_base>(trans_ocaml_questions a)) ;;

let save_xml_demexp (f : Latin1)(c : Ocaml_xml_content) : [] =
  let content = match c with
   { version=v; participants=p; tags=t; questions=q } -> <demexp_base version=v>[
    <participant_base>(trans_ocaml_participants p)
    <classification_base>(trans_ocaml_tags t)
    <question_base>(trans_ocaml_questions q)
    ] in
      dump_to_file_utf8 f ("<?xml version=\"1.0\"?>" @ (print_xml_utf8 content))
  ;;