(* 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)* ] |} ;;


(* transformation function *)

let trans_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=(transform g with <group>s -> [s]) })
      | _ -> raise "Invalid p_id value"
  ;;

let trans_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_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_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_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_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_participants ([d]/Xml_participant_base/Xml_participant));
    tags=(trans_tags ([d]/Xml_classification_base/Xml_tag));
    questions=(trans_questions ([d]/Xml_question_base/Xml_question)) }    
  ;;