Source file contrib.ml

(*********************************************************************************)
(*                Statocaml                                                      *)
(*                                                                               *)
(*    Copyright (C) 2025 INRIA All rights reserved.                              *)
(*    Author: Maxence Guesdon (INRIA Saclay)                                     *)
(*      with Gabriel Scherer (INRIA Paris) and Florian Angeletti (INRIA Paris)   *)
(*                                                                               *)
(*    This program 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, version 3 of the License.       *)
(*                                                                               *)
(*    This program 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 this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** *)


module S = Statocaml
module T = Statocaml_profile.T
module W = Ocf.Wrapper
module GH = Statocaml_github

module XR = Xtmpl.Rewrite

module Make (P:T.S) =
  struct
    let point_char = "⬤"

    let xml_text_node_contents xmls =
      match List.find_opt
        (function XR.E { name = ("","text") } -> true | _ -> false)
          xmls
      with
      | None -> None
      | Some (E node) -> Some (XR.text_of_xmls node.subs)
      | Some _ -> assert false


    let svg_add_info =
      let re = Re.(compile (seq [
            group ~name:"name" (rep1 (compl [ char ','])) ;
            char ',' ;
            group ~name:"id" (rep1 digit) ;
          ]))
      in
      let gnames = Re.group_names re in
      let get gname =
        let n = List.assoc gname gnames in
        fun g -> Re.Group.get g n
      in
      let get_name = get "name" in
      let get_id = get "id" in
      let rec iter f_href = function
      | (XR.E ({ name = ("","g") ; subs } as node)) as x ->
          (
           match xml_text_node_contents subs with
           | None ->
               let subs = List.map (iter f_href) subs in
               XR.E { node with subs }
           | Some text ->
               match Re.exec_opt re text with
               | None -> x
               | Some g ->
                   let name = get_name g in
                   let id = int_of_string (get_id g) in
                   let href = Iri.to_string (f_href id) in
                   let subs = [ XR.node ("","a")
                     ~atts:(XR.atts_one ("xlink","href") [XR.cdata href])
                       [
                         XR.node ("","title") [XR.cdata name] ;
                         XR.node ("","text") [XR.cdata point_char] ;
                       ]
                     ]
                   in
                   XR.E { node with subs  }
          )
      | XR.E node ->
          let subs = List.map (iter f_href) node.subs in
          XR.E { node with subs }
      | x -> x
      in
      fun f_href svg -> List.map (iter f_href) svg

    let prepare_data ?after ?before ?release data =
      let pred : (GH.Types.issue -> bool) * (P.pr -> bool) =
        let f_true = fun _ -> true in
        let f_true2 = f_true, f_true in
        match after, before, release, data.P.orig_changelog with
        | None, None, None, _ -> f_true2
        | _, _, Some _release, None ->
            failwith "Filtering according to release but data has no changelog"
        | _, _, None, _ ->
            let pafter = match after with
              | None -> f_true
              | Some than -> (fun i -> Ptime.is_later ~than i.GH.Types.created_at)
            in
            let pbefore = match before with
              | None -> f_true
              | Some than -> (fun i -> Ptime.is_earlier ~than i.GH.Types.created_at)
            in
            (fun i -> pafter i && pbefore i),
            (fun pr -> pafter pr.issue && pbefore pr.issue)

        | _, _, Some release, Some changelog ->
            match Changelog.release_of_version changelog release with
            | None ->
                S.Log.err (fun m -> m "No release %S in changelog" release);
                (fun _ -> false), (fun _ -> false)
            | Some rel ->
                let d = S.Period.(Map.find All data.stats) in
                let f_ref (issues,prs) id =
                  match S.Imap.find_opt id d.g_issues with
                  | Some _ -> (S.Iset.add id issues, prs)
                  | None ->
                      match S.Imap.find_opt id d.g_prs with
                      | Some _ -> (issues, S.Iset.add id prs)
                      | None ->
                          S.Log.err (fun m -> m "No issue or PR %d" id);
                          (issues, prs)
                in
                let f_entry acc entry = List.fold_left f_ref acc entry.Changelog.references in
                let f_cat _ entries acc = List.fold_left f_entry acc entries in
                let issues, prs = S.Smap.fold f_cat rel.categories (S.Iset.empty, S.Iset.empty) in
                (fun (i:GH.Types.issue) -> S.Iset.mem i.GH.Types.number issues),
                (fun pr -> S.Iset.mem pr.P.issue.number prs)
      in
      let pred_issues, pred_prs = pred in
      let period_issues, period_prs =
        let d = S.Period.(Map.find All data.stats) in
        let filter pred map =
          S.Imap.fold (fun id x acc -> if pred x then S.Iset.add id acc else acc)
            map S.Iset.empty
        in
        filter pred_issues d.g_issues,
        filter pred_prs d.g_prs
      in
      let profiles = P.profiles data in
      let f _id p acc =
        match P.opt_dated p S.Period.All with
        | None -> acc
        | Some d ->
            let filter in_set set =
              S.Iset.filter (fun id -> S.Iset.mem id in_set) set
            in
            let i_created = filter period_issues d.issues_created in
            let i_reviewed = filter period_issues d.issues_reviewed in
            let pr_created = filter period_prs d.prs_created in
            let pr_reviewed = filter period_prs
              (if data.has_changelog
               then d.prs_reviewed_from_changelog
               else d.prs_reviewed)
            in
            (p, i_created, i_reviewed, pr_created, pr_reviewed) :: acc
      in
      let list = S.Imap.fold f profiles [] in
      list

    let plot (gp:Plot.gp) ?(with_node_info=false) ?after ?before ?period_name ?release (data: P.t) =
      let pdata = prepare_data ?after ?before ?release data in
      let pdata =
        let c = S.Iset.cardinal in
        List.filter_map
          (fun (p,ic,ir,pc,pr) ->
             let created = c ic + c pc in
             let reviewed = c ir + c pr in
             if created = 0 && reviewed = 0 then
               None
             else
               Some (float created, float reviewed, (created+reviewed) mod 12,
                if with_node_info
                then Printf.sprintf "%s (%d/%d),%d" p.P.name reviewed created p.id
                else point_char))
          pdata
      in
      ignore(period_name);
      let xmax, ymax = List.fold_left
        (fun (x,y) (created,reviewed,_,_) -> (max x created, max y reviewed))
          (1., 1.) pdata
      in
      match pdata with
      | [] -> Lwt.return_unit
      | _ ->
          (* code partially taken from Florian Angeletti *)
          Plot.p gp "set encoding utf8";
          Plot.p gp "set xlabel \"number of authored contributions\"" ;
          Plot.p gp "set ylabel \"number of reviews\"" ;
          Plot.p gp "xmax = %f" xmax ;
          Plot.p gp "ymax = %f" ymax ;
          Plot.p gp "xzero = 0.7" ;
          Plot.p gp "yzero = 0.7" ;
          Plot.p gp "set xrange [0.5:(1+log10(xmax))]" ;
          Plot.p gp "set yrange [0.5:(1+log10(ymax))]" ;
          Plot.p gp "unset ytics
            set ytics 1 add (\"0\" yzero, \"1\" 1)
            set for [i=2:(1+log10(ymax+1))] ytics add (sprintf(\"%%g\",10**(i-1)) i) # Add major tics
            set for [i=1:(1+log10(ymax+1))] for [j=2:9] ytics add (\"\" log10(10**i*j) 1) # Add minor tics
            unset xtics
            set xtics 1 add (\"0\" xzero, \"1\" 1)
            set for [i=2:(1+log10(xmax+1))] xtics add (sprintf(\"%%g\",10**(i-1)) i) # Add major tics
            set for [i=1:(1+log10(xmax+1))] for [j=2:9] xtics add (\"\" log10(10**i*j) 1) # Add minor tics
            set grid
            set grid mxtics mytics";


          Plot.define_float_float_int_string_data gp "data" pdata ;
          Plot.p gp "set dataf sep \"\\t\"";
          Plot.p gp "f(x) = (x)";
          Plot.p gp "plot \
            for[i=0:%d] $data every 1:1:i:0:i:0 \
            using ($1<1?xzero+(1-xzero)*$1:1 + log10($1)):($2<1?yzero+(1-yzero)*$2:1 + log10($2)):(stringcolumn(4)) with labels tc lt (i %% 12 + 1) notitle, \
            f(x) notitle with lines dt 7 lc rgb \"grey\""
             (List.length pdata - 1);
(*"             $data using 1:2:(stringcolumn(4)) \
            with labels hypertext point pt 5 ps 1 lc rgb \"#ffee99\" notitle, \
"*)
          S.Log.info (fun m -> m "Contrib.plot:%s" (Plot.code gp));
          Lwt.return_unit

    type param =
      { after: Ptime.t option [@ocf W.option S.Types.ptime_date_wrapper, None];
        before: Ptime.t option [@ocf W.option S.Types.ptime_date_wrapper, None];
        period_name : string option [@ocf W.option W.string, None];
        release : string option [@ocf W.option W.string, None];
        with_node_info : bool [@ocf W.bool, false] ;
      }[@@ocf]

    let wrap_param f =
      Json.to_plotter param_wrapper
        (fun gp p -> f gp
           ?with_node_info:(Some p.with_node_info)
           ?after:p.after ?before:p.before
             ?period_name:p.period_name ?release:p.release
        )

    let plot_json = wrap_param plot
  end