(*
This file is part of Ceve.

Ceve is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

Ceve 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 General Public License for more details.

You should have received a copy of the GNU General Public License
along with Ceve; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

(**
Writer for the EGraph format.
@author Jaap Boender
*)

open Egraph
open Napkin

{{ namespace "http://graphml.graphdrawing.org/xmlns/1.0rc" }}
{{ namespace edos = "http://www.edos-project.org/egraph" }}

let node_from_package (pkg: default_package): {{ node_type }} =
begin
	{{
		<node package={: pkg.pk_unit :} id={: pkg.pk_unit :}>[
			(* <desc>{: pkg.summary :} *)
			<data key="nodedata">[
				<edos:version number={: pkg.pk_version :} (* filename={: pkg.filename :} *)>[]
			]	
		]
	}}
end;;

let edges_from_packages (pkgs: default_package list): {{ edge_type | hyperedge_type }} list =
let operator_of vs =
begin
	match vs with
	| Sel_ANY -> "all"
	| Sel_LT _ -> "lt"
	| Sel_LEQ _ -> "le"
	| Sel_EQ _ -> "eq"
	| Sel_GEQ _ -> "ge"
	| Sel_GT _ -> "gt"
end
and target_of vs =
begin
	match vs with
	| Sel_ANY -> ""
	| Sel_LT v | Sel_LEQ v | Sel_EQ v | Sel_GT v | Sel_GEQ v -> v
end
and source_ht = Hashtbl.create (List.length pkgs) in
let result = ref [] in
begin
	List.iter (fun pkg ->
	(* Depends: *)
	let run_ht = try Hashtbl.find source_ht (pkg.pk_unit, "run")
	with Not_found -> Hashtbl.create (List.length pkg.pk_depends) in
		List.iter (fun disj ->
			let targets = List.map (fun x ->
				match x with
				| Unit_version (y, _) -> y
				| Glob_pattern _ -> raise (Failure "ARGH XIII")
			) disj in
			let version_list = try Hashtbl.find run_ht targets
			with Not_found -> List.map (fun x -> []) disj in
				Hashtbl.replace run_ht targets (List.map2 (fun old add ->
					add::old	
				) version_list (List.map (fun x ->
					match x with
					| Unit_version (_, y) -> (pkg.pk_version, y)
					| Glob_pattern _ -> raise (Failure "ARGH XIV")
				) disj))
		) pkg.pk_depends;
		Hashtbl.replace source_ht (pkg.pk_unit, "run") run_ht;
	(* Pre-Depends: *)
	let install_ht = try Hashtbl.find source_ht (pkg.pk_unit, "install")
	with Not_found -> Hashtbl.create (List.length pkg.pk_pre_depends) in
		List.iter (fun disj ->
			let targets = List.map (fun x ->
				match x with
				| Unit_version (y, _) -> y
				| Glob_pattern _ -> raise (Failure "ARGH XV")
			) disj in
			let version_list = try Hashtbl.find install_ht targets
			with Not_found -> List.map (fun x -> []) disj in
				Hashtbl.replace install_ht targets (List.map2 (fun old add ->
					add::old	
				) version_list (List.map (fun x ->
					match x with
					| Unit_version (_, y) -> (pkg.pk_version, y)
					| Glob_pattern _ -> raise (Failure "ARGH XVI")
				) disj))
		) pkg.pk_pre_depends;
		Hashtbl.replace source_ht (pkg.pk_unit, "install") install_ht;
	(* Recommends: *)
	let recommend_ht = try Hashtbl.find source_ht (pkg.pk_unit, "recommend")
	with Not_found -> Hashtbl.create (List.length pkg.pk_recommends) in
		List.iter (fun disj ->
			let targets = List.map (fun x ->
				match x with
				| Unit_version (y, _) -> y
				| Glob_pattern _ -> raise (Failure "ARGH XVII")
			) disj in
			let version_list = try Hashtbl.find recommend_ht targets
			with Not_found -> List.map (fun x -> []) disj in
				Hashtbl.replace recommend_ht targets (List.map2 (fun old add ->
					add::old	
				) version_list (List.map (fun x ->
					match x with
					| Unit_version (_, y) -> (pkg.pk_version, y)
					| Glob_pattern _ -> raise (Failure "ARGH XVII")
				) disj))
		) pkg.pk_recommends;
		Hashtbl.replace source_ht (pkg.pk_unit, "recommend") recommend_ht;
	(* Suggests: *)
	let suggest_ht = try Hashtbl.find source_ht (pkg.pk_unit, "suggest")
	with Not_found -> Hashtbl.create (List.length pkg.pk_suggests) in
		List.iter (fun disj ->
			let targets = List.map (fun x ->
				match x with
				| Unit_version (y, _) -> y
				| Glob_pattern _ -> raise (Failure "ARGH XVIII")
			) disj in
			let version_list = try Hashtbl.find suggest_ht targets
			with Not_found -> List.map (fun x -> []) disj in
				Hashtbl.replace suggest_ht targets (List.map2 (fun old add ->
					add::old	
				) version_list (List.map (fun x ->
					match x with
					| Unit_version (_, y) -> (pkg.pk_version, y)
					| Glob_pattern _ -> raise (Failure "ARGH XIX")
				) disj))
		) pkg.pk_suggests;
		Hashtbl.replace source_ht (pkg.pk_unit, "suggest") suggest_ht;
	(* Enhances: *)
	let enhance_ht = try Hashtbl.find source_ht (pkg.pk_unit, "enhance")
	with Not_found -> Hashtbl.create (List.length pkg.pk_enhances) in
		List.iter (fun disj ->
			let targets = List.map (fun x ->
				match x with
				| Unit_version (y, _) -> y
				| Glob_pattern _ -> raise (Failure "ARGH XX")
			) disj in
			let version_list = try Hashtbl.find enhance_ht targets
			with Not_found -> List.map (fun x -> []) disj in
				Hashtbl.replace enhance_ht targets (List.map2 (fun old add ->
					add::old	
				) version_list (List.map (fun x ->
					match x with
					| Unit_version (_, y) -> (pkg.pk_version, y)
					| Glob_pattern _ -> raise (Failure "ARGH XXI")
				) disj))
		) pkg.pk_enhances;
		Hashtbl.replace source_ht (pkg.pk_unit, "enhance") enhance_ht;
	(* Conflicts: *)
	let conflict_ht = try Hashtbl.find source_ht (pkg.pk_unit, "conflict")
	with Not_found -> Hashtbl.create (List.length pkg.pk_conflicts) in
		List.iter (fun dep ->
			let targets = match dep with
				| Unit_version (x, _) -> [x]
				| Glob_pattern _ -> raise (Failure "ARGH XXII") in
			let version_list = try Hashtbl.find conflict_ht targets
			with Not_found -> [[]] in
				Hashtbl.replace conflict_ht targets (List.map2 (fun old add ->
					add::old
				) version_list [(pkg.pk_version, match dep with
					| Unit_version (_, x) -> x
					| Glob_pattern _ -> raise (Failure "ARGH XXIII"))])
		) pkg.pk_conflicts;
		Hashtbl.replace source_ht (pkg.pk_unit, "conflict") conflict_ht;
	(* Replaces: *)
	let replace_ht = try Hashtbl.find source_ht (pkg.pk_unit, "replace")
	with Not_found -> Hashtbl.create (List.length pkg.pk_replaces) in
		List.iter (fun dep ->
			let targets = match dep with
				| Unit_version (x, _) -> [x]
				| Glob_pattern _ -> raise (Failure "ARGH XXIV") in
			let version_list = try Hashtbl.find replace_ht targets
			with Not_found -> [[]] in
				Hashtbl.replace replace_ht targets (List.map2 (fun old add ->
					add::old
				) version_list [(pkg.pk_version, match dep with
					| Unit_version (_, x) -> x
					| Glob_pattern _ -> raise (Failure "ARGH XXV"))])
		) pkg.pk_replaces;
		Hashtbl.replace source_ht (pkg.pk_unit, "replace") replace_ht;
	(* Provides: *)
	let provide_ht = try Hashtbl.find source_ht (pkg.pk_unit, "provide")
	with Not_found -> Hashtbl.create (List.length pkg.pk_provides) in
		List.iter (fun dep ->
			let targets = match dep with
				| Unit_version (x, _) -> [x]
				| Glob_pattern _ -> raise (Failure "ARGH XXVI") in
			let version_list = try Hashtbl.find provide_ht targets
			with Not_found -> [[]] in
				Hashtbl.replace provide_ht targets (List.map2 (fun old add ->
					add::old
				) version_list [(pkg.pk_version, match dep with
					| Unit_version (_, x) -> x
					| Glob_pattern _ -> raise (Failure "ARGH XXVII"))])
		) pkg.pk_provides;
		Hashtbl.replace source_ht (pkg.pk_unit, "provide") provide_ht
	) pkgs;
	Hashtbl.iter (fun (sn, tp) tns_versions ->
		Hashtbl.iter (fun tns versions ->
			if List.length tns = 1 then
				result := {{ <edge type={: tp :} source={: sn :} target={: List.hd tns :}>[
					<data key="edgedata">		
						{: List.map (fun (sv, tv) -> 
								{{ <edos:version operator={: operator_of tv :} source={: sv :} target={: target_of tv :}>[] }}
							) (List.hd versions)
						:}
				]}}::!result
			else
				result := {{ <hyperedge type={: tp :}>(
					[<endpoint type="out" node={: sn :}>[]] @
					{: List.map2 (fun tn stvs -> 
						{{ <endpoint type="in" node={: tn :}>[
								<data key="endpointdata">(
									{: List.map (fun (sv, tv) -> {{ <edos:version operator={: operator_of tv :} source={: sv :} target={: target_of tv :}>[] }}) stvs :} 
						)]}}
					) tns versions :}
				)}}::!result
		) tns_versions
	) source_ht;
	!result
end;;

let output_egraph (pkgs: default_package list): unit =
let vt_name (vt: Options.version_types): string =
begin
	match vt with
		Options.Unspecified -> "unspecified"
	| Options.RPMVersions -> "rpm"
	| Options.DebianVersions -> "debian"
end
and packages = List.rev_map node_from_package pkgs
and edges = edges_from_packages pkgs in
begin
	prerr_endline "[XML] Outputting EGraph file...";
	let (output: {{ graphml_type }}) = {{
		<graphml>[
			<graph edgedefault="directed" version_type={: vt_name !Options.version_type :}>(
				{: packages :} @
				{: edges :}
			)
		]
	}} in
	Ocamlduce.Print.print_xml (output_string !Options.output_channel) output
end;;
