(* Dump *)
(* $Id: dump.ml,v 1.1 2004/10/26 09:44:54 berke Exp $ *)

module Make(Dpkg : Dpkg.DB) =
  struct
open Dpkg
open Opt

let iter_over_packages db x f = List.iter f x;;
let sf = Printf.sprintf;;

(*** bourbaki_dump_abstract *)
let bourbaki_dump writer ~versions db x =
  iter_over_packages db x (fun i ->
    try
      let p = name_of db i in
      if versions then writer#output_word (p^"("^(version_of db i)^")")
      else writer#output_word p
    with
    | Not_found -> writer#output_word (sf "(%d)" i));
  writer#flush
;;
(* ***)

(*** list_dump *)
let list_dump writer ~versions db x =
  iter_over_packages db x (fun i ->
    try
      if versions then
        writer#output_word (sf "%s (%s)" (name_of db i) (version_of db i))
      else
        writer#output_word (sf "%s" (name_of db i));
      writer#flush
    with
    | Not_found -> writer#output_word (sf "package-%d" i))
;;
(* ***)

let default_field_order = ["Package"],["Description"];;

(*** compute_fields *)
let compute_fields ?(field_order=default_field_order) db fd =
  let (pre_fields, post_fields) = field_order in
  let convert = List.map (fun x -> field_of_string db (String.lowercase x)) in
  let pre_fields = convert pre_fields
  and post_fields = convert post_fields
  in
  let fields = get_fields db in
  let rec other i r =
    if i = Array.length fields then
      r
    else
        other (i + 1)
          (if List.mem i pre_fields or List.mem i post_fields then
            r
          else
            i::r)
  in
  let other_fields = other 0 [] in
  (pre_fields, other_fields, post_fields)
;;
(* ***)

(*** raw_dump *)
let raw_dump writer db fd x =
  let pf = new Dpkg.paragraph_folder in
  let columns = writer#columns in
  let (pre_fields, other_fields, post_fields) = compute_fields db fd in
  let convert = List.map (fun x -> field_of_string db (String.lowercase x)) in
  let f = match fd with
  | All ->
      fun g ->
        List.iter g pre_fields;
        List.iter g other_fields;
        List.iter g post_fields
  | These l ->
      let l' = convert (List.map (fun (x,_) -> x) l) in
      let pre_fields = Util.list_intersect l' pre_fields
      and other_fields = Util.list_intersect l' other_fields
      and post_fields = Util.list_intersect l' post_fields
      in
      fun g ->
        List.iter g pre_fields;
        List.iter g other_fields;
        List.iter g post_fields
  in
  let sep = String.make columns '-' in
  let nearly = ref false in
  iter_over_packages db x
    (fun i ->
      if !nearly then writer#newline else nearly := true;
      writer#output_word sep;
      writer#flush;
      f (fun j ->
           let u = get_field db i j in
           if u <> "" then
             begin
               try
                 ignore (String.index u '\n');
                 pf#reset;
                 pf#add_string u;
                 writer#output
                   (sf "%s: %s" (display_name_of_field db j)
                     (pf#get))
               with
               | Not_found ->
                 writer#output (sf "%s: %s\n" (display_name_of_field db j) u)
             end
           else
             ());
      writer#flush;
      writer#output_word sep;
      writer#flush);
;;
(* ***)
(*** table_dump *)
let table_dump writer db ?(field_order=default_field_order) ~borders fd x =
  let headers = borders in
  let (pre_fields, post_fields) = field_order in
  let convert = List.map (fun x -> field_of_string db (String.lowercase x)) in
  let pre_fields = convert pre_fields
  and post_fields = convert post_fields
  in
  let fields = get_fields db in
  let l = match fd with
  | All ->
    let rec other i r =
      if i = Array.length fields then
        r
      else
        other (i + 1)
          (if List.mem i pre_fields or List.mem i post_fields then
            r
          else
            (i,None)::r)
    in
    other 0 []
  | These(l) -> List.map (fun (w,x) -> (field_of_string db (String.lowercase w), x)) l
  in
  (*List.fold_left
    (fun cols i ->
      SM.fold (fun key _ cols -> SS.add key cols) db.db.(i) cols)
    SS.empty x*)
  let a = Array.of_list l in
  let n = Array.length a in
  let b =
    if headers then
      Array.map String.length (get_display_names db)
    else
      Array.make (Array.length (get_display_names db)) 0
  in
  (* compute maximum width *)
  for i = 0 to Array.length b - 1 do
    iter_over_packages db x
    (fun j -> (* iterate on packages *)
      b.(i) <- max b.(i) (String.length (Util.first_line (get_field db j i))))
  done;
  let b = 
    Array.mapi (fun i x ->
      try
        match List.assoc i l with
        | None -> x
        | Some y -> min x y
      with
      | Not_found -> 0) b
  in
  let total = Array.fold_left (+) 0 b in
  let dashes () =
    begin
      for i = 0 to n - 1 do
        writer#output_string "+--";
        let (fd,_) = a.(i) in
        for j = 0 to b.(fd) - 1 do
          writer#output_char '-'
        done;
      done;
      writer#output_char '+';
      writer#output_char '\n'
    end
  in
  let spaces n =
    for i = 1 to n do
      writer#output_char ' '
    done
  in
  if headers then
    begin
      if borders then dashes ();
      if borders then writer#output_string "| ";
      let display_names = get_display_names db in
      for i = 0 to n - 1 do
        if i > 0 then
          writer#output_char ' ';
        let (fd,_) = a.(i) in
        let w = display_names.(fd) in
        writer#output_string w;
        spaces (b.(fd) - String.length w);
        if borders then writer#output_string " |"
      done;
      writer#output_char '\n';
    end;
  if borders then dashes ();
  iter_over_packages db x
    (fun i -> (* iterate over packages *)
      if borders then writer#output_string "| ";
      for j = 0 to n - 1 do
        if j > 0 then writer#output_char ' ';
        let (fd,lm) = a.(j) in
        let w = Util.first_line (get_field db i fd) in
        let p =
          match lm with
          | None -> String.length w
          | Some p -> p
        in
        let w = Util.limit p w in
        writer#output_string w;
        if borders or j < n - 1 then spaces (b.(fd) - String.length w);
        if borders then writer#output_string " |"
      done;
      writer#output_char '\n');
  if borders then dashes ()
;;
(* ***)
end
