(**************************************************************************)
(*                                                                        *)
(*  Copyright (C) 2012 Johannes 'josch' Schauer <j.schauer@email.de>      *)
(*  Copyright (C) 2012 Pietro Abate <pietro.abate@pps.jussieu.fr>         *)
(*                                                                        *)
(*  This library is free software: you can redistribute it and/or modify  *)
(*  it under the terms of the GNU Lesser General Public License as        *)
(*  published by the Free Software Foundation, either version 3 of the    *)
(*  License, or (at your option) any later version.  A special linking    *)
(*  exception to the GNU Lesser General Public License applies to this    *)
(*  library, see the COPYING file for more information.                   *)
(**************************************************************************)

open! ExtLib
open Datatypes_t
open Dose_common
open Dose_debian
open Dose_doseparse

#define __label __FILE__
let label =  __label ;;
include Util.Logging(struct let label = label end) ;;

let str_list_option ?(default=Some []) ?(metavar = "STRLST") =
  let sep = "," in
  let coerce s = ExtString.String.nsplit s sep in
  fun () ->
    OptParse.Opt.value_option metavar default coerce
    (fun _ s -> Printf.sprintf "Invalid String '%s'" s)

module StringSet = BootstrapCommon.StringSet
module IntSet = BootstrapCommon.IntSet

module Options = struct
  open OptParse
  let usage = "%prog [options] --deb-native-arch=ARCH buildgraph srcgraph Packages Sources"
  let description = "output statistics in JSON format"
  let options = OptParser.make ~description ~ usage
  include BootstrapCommon.MakeOptions(struct let options = options end)

  let cycle_length = StdOpt.int_option ~default:2 ()
  let cycle_length_fas = StdOpt.int_option ~default:8 ()
  let remove_weak = StdOpt.str_option ()
  let remove_reduced = str_list_option ()
  let sapsb = StdOpt.store_true ()
  let allowsrcmismatch = StdOpt.store_true ()
  let available = StdOpt.str_option ()

  open OptParser ;;

  let prog_group = add_group options "Program specific options" in

  add options ~group:prog_group ~long_name:"max-length" ~help:"maximum length of found cycles (default=2)" cycle_length;
  add options ~group:prog_group ~long_name:"max-length-fas" ~help:"maximum length of found cycles for fas search (default=4)" cycle_length_fas;
  add options ~group:prog_group ~long_name:"remove-weak" ~help:"path to list of weak build dependencies" remove_weak;
  add options ~group:prog_group ~long_name:"sapsb" ~help:"calculate strong articulation points and strong bridges" sapsb;
  add options ~group:prog_group ~long_name:"remove-reduced" ~help:"remove droppable build dependencies supplied by comma separated list of reduced dep files" remove_reduced;
  add options ~group:prog_group ~short_name:'A' ~long_name:"available"
    ~help:"List of available packages (arch:all, crossed...) in control file format" available;

  add options ~group:prog_group ~long_name:"allowsrcmismatch" ~help:("If a binary package is "^
    "without a source package but there is a source package of same name but "^ 
    "different version, match this binary package to that source package.") allowsrcmismatch;

  include StdOptions.InputOptions;;
  let default = List.filter (fun e -> not (List.mem e ["compare"; "checkonly"; "latest";"outfile";"inputtype"])) StdOptions.InputOptions.default_options in
  StdOptions.InputOptions.add_options ~default options ;;

  include StdOptions.DistribOptions;;
  let default = List.filter (fun e -> not (List.mem e ["deb-profiles"; "deb-ignore-essential"; "deb-builds-from"])) StdOptions.DistribOptions.default_options in
  StdOptions.DistribOptions.add_debian_options ~default options ;;

end

let main () =
  let posargs = OptParse.OptParser.parse_argv Options.options in
  StdDebug.enable_debug (OptParse.Opt.get Options.verbose);
  Util.Debug.disable "Depsolver_int";
  Util.Warning.disable "Sources"; (* disable MismatchSrc warnings as exception is caught *)
  StdDebug.all_quiet (OptParse.Opt.get Options.quiet);
  let maxlengthfas = OptParse.Opt.get Options.cycle_length_fas in
  let maxlength = OptParse.Opt.get Options.cycle_length in
  let reduced_deps_files = OptParse.Opt.get Options.remove_reduced in
  let allowsrcmismatch = OptParse.Opt.get Options.allowsrcmismatch in
  let options = Options.set_deb_options () in
  let noindep = options.Debcudf.drop_bd_indep in
  let buildarch = Option.get options.Debcudf.native in
  let hostarch = match options.Debcudf.host with None -> "" | Some s -> s in
  let foreignarchs = options.Debcudf.foreign in

  let bgf, sgf, posargs = match posargs with
   | bgf::sgf::l -> bgf,sgf,l
   | _ -> fatal "you must provide buildgraph, srcgraph, Packages and Sources"
  in

  let (binlist, (fgsrclist,bgsrclist), _) = BootstrapCommon.parse_packages ~noindep Options.parse_cmdline buildarch hostarch foreignarchs posargs in

  let tables = Debcudf.init_tables (fgsrclist@bgsrclist@binlist) in
  let fgsl = List.map (Debcudf.tocudf ?inst:None ~options tables) fgsrclist in
  let bgsl = List.map (Debcudf.tocudf ?inst:None ~options tables) bgsrclist in
  let pkglist = List.map (Debcudf.tocudf ?inst:None ~options tables) binlist in
  let universe = Cudf.load_universe (BootstrapCommon.unique [pkglist;fgsl;bgsl]) in

  let module BG = BuildGraph.G in
  let module SG = SrcGraph.G in

  let ic = open_in bgf in
  let bg = BuildGraph.from_ic universe buildarch ic in
  close_in ic;

  let ic = open_in sgf in
  let sg = SrcGraph.from_ic universe buildarch ic in
  close_in ic;

  (* read package list for available packages *)
  let availableset =
    if OptParse.Opt.is_set Options.available then
      BootstrapCommon.read_package_file ~archs:(buildarch::hostarch::foreignarchs) (Debcudf.tocudf ?inst:None ~options tables) (OptParse.Opt.get    Options.available)
    else CudfAdd.Cudf_set.empty
  in

  let module BGE = BuildGraphExtras.Make(struct let univ = universe end) in
  let module BGS = BuildGraphStats.Make(struct let univ = universe end) in
  let module SGE = SrcGraphExtras.Make(struct let univ = universe end) in
  let module SGS = SrcGraphStats.Make(struct let univ = universe end) in

  let binset = BootstrapCommon.get_bin_packages (BootstrapCommon.srcbin_table ~available:availableset ~allowmismatch:allowsrcmismatch universe) in

  let type1, type2, type3 = SGS.self_cycles binset sg in

  let srcpkglist = BGE.srcpkglist_of_g bg in
  let weak_file =
    if OptParse.Opt.is_set Options.remove_weak then
      OptParse.Opt.get Options.remove_weak
    else
      ""
  in
  let reduced_deps_ht, weak_deps_set = BootstrapCommon.get_reduced_deps_ht ~weak_file (OptParse.Opt.is_set Options.remove_weak) (buildarch::foreignarchs) srcpkglist reduced_deps_files in
  BGE.remove_build_deps reduced_deps_ht bg;

  let scc = List.filter_map (function [] | [_] -> None | s -> Some (BuildGraph.Oper.subgraph bg s)) (BuildGraph.Comp.scc_list bg) in

  (* cudf to debian binary/source converter shorthands *)
  let c2b = BootstrapCommon.debbintriplet_of_cudfpkg in
  let c2s = BootstrapCommon.debsrctuple_of_cudfpkg in
  let c2bl = List.map c2b in
  let c2sl = List.map c2s in

  let result = {
    srcgraph = {
      snr_vertex = SG.nb_vertex sg;
      snr_edges = SG.nb_edges sg;
      type1cycles = List.map (fun (pkg, d1, d2) -> (c2s pkg, c2bl d1, c2bl d2)) type1;
      type2cycles = List.map (fun (pkg, d1, d2) -> (c2s pkg, c2bl d1, c2bl d2)) type2;
      type3cycles = List.map (fun (pkg, deps) -> (c2s pkg, c2bl deps)) type3;
    };
    buildgraph = {
      bnr_vertex = BG.nb_vertex bg;
      bnr_edges = BG.nb_edges bg;
      sccs = List.map (fun sg ->
        let cycles, cycleedge = if maxlength > 0 then begin
          let cycles = BuildGraph.Cycles.johnson ~maxlength sg in
          cycles, (BGS.edges_in_most_cycles sg cycles)
        end else [], [] in
        let fas = if maxlengthfas > 0 then begin
          let ht_fas = Hashtbl.create (BG.nb_edges sg) in
          BuildGraph.EdgeSet.iter (fun (src,_,pkg) ->
            Hashtbl.replace ht_fas src (pkg::(Hashtbl.find_default ht_fas src []))
          ) (BGE.calculate_fas ~maxlength:maxlengthfas sg);
          Hashtbl.fold (fun k v acc -> (k,v)::acc) ht_fas []
        end else [] in
        let sap, sb = if OptParse.Opt.get Options.sapsb then begin
          let sap = BuildGraph.Utils.find_strong_articulation_points sg in
          let sb = BuildGraph.Utils.find_strong_bridges sg in
          sap, sb
        end else [], [] in
        {
          sg_vertex = BG.nb_vertex sg;
          sg_edges = BG.nb_edges sg;
          cycles = List.map BGE.variantlist_of_vlist cycles;
          cycleedge = List.map (fun ((v1,_,v2),c) -> ((BGE.variant_of_vertex v1), (BGE.variant_of_vertex v2)), c) cycleedge;
          builddeps = List.map (fun (p,deps) -> c2s p, c2bl deps) (BGS.min_builddep sg);
          ratio_source = List.map (fun (s,b,n,o) -> c2s s, b, c2bl n, c2sl o) (BGS.ratio_source sg);
          ratio_binary = List.map (fun (b,s,o) -> c2b b, s, c2sl o) (BGS.ratio_binary sg);
          weak = List.map (fun (pkg, deps) -> c2s pkg, c2bl deps) (BGS.only_weak_missing weak_deps_set sg);
          srcbinstats = List.map (fun (v,s,p) -> (BGE.variant_of_vertex v), s, p) (BGS.get_src_bin_stats sg);
          fas = List.map (fun (p,deps) -> c2s (BGE.pkg_of_vertex p), c2bl (BGE.pkglist_of_vlist deps)) fas;
          sap = List.map (fun (p,i) -> (BGE.variant_of_vertex p), i) sap;
          sb = List.map (fun ((v1,_,v2),i) -> (BGE.variant_of_vertex v1, BGE.variant_of_vertex v2), i) sb;
        }
      ) scc;
    };
  } in

  (* we let this program output un-prettified JSON because to prettify we'd
   * have to store the JSON data in a string which easily exceeds the maximum
   * OCaml string length on 32 bit systems. Instead, the output of this program
   * can be piped to ydump to prettify it.
   *
   * https://github.com/mjambon/atdgen/issues/43
   * *)
  let ob = Bi_outbuf.create_channel_writer stdout in
  Datatypes_j.write_stats ob result;
  Bi_outbuf.flush_channel_writer ob;
;;

main ();;
