Source file subsys.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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Subsystems *)

module GH = Statocaml_github
open GH.Types

module type P = sig
    type t
    val compare : t -> t -> int
    val list : t list
    val to_string : t -> string
    val list_of_filename : string -> t list
    val list_of_label : string -> t list
    val to_dot_color : t -> string
  end

module type S = sig
  include P
  module Map : Map.S with type key = t
  module Set : Set.S with type elt = t

  (** From a commit, return the set of subsystems,
    let number of files for each subsystem and the number
    of lines added and deleted for each subsystem *)
  val of_commit : GH.Types.commit -> Set.t * int Map.t * int Map.t
  val of_issue : GH.Types.issue -> Set.t
  val commits_by_t : GH.Types.commit list -> GH.Types.commit list Map.t
  val issues_by_t : GH.Types.issue list -> GH.Types.issue list Map.t
  end

module Make (P:P) : S with type t = P.t = struct
  include P
  module Map = Map.Make(P)
  module Set = Set.Make(P)

  let add_list_to_set l set = List.fold_right Set.add l set
  let inc_list_in_map =
    let f v ss map = match Map.find_opt ss map with
      | None -> Map.add ss v map
      | Some v0 -> Map.add ss (v0+v) map
    in
    fun ?(v=1) l map -> List.fold_right (f v) l map

  let of_commit (c:commit) =
    let f (set, files, lines) (file:commit_file) =
      let ss = P.list_of_filename file.filename in
      let files = inc_list_in_map ss files in
      let lines = inc_list_in_map ~v:(file.additions+file.deletions) ss lines in
      let set = add_list_to_set ss set in
      (set, files, lines)
    in
    List.fold_left f (Set.empty, Map.empty, Map.empty) c.files

  let of_issue (i:issue) =
    let f set (label:label) =
      add_list_to_set (P.list_of_label label.name) set
    in
    List.fold_left f Set.empty i.labels

  let commits_by_t commits =
      let add commit t map =
        match Map.find_opt t map with
        | None -> Map.add t [commit] map
        | Some l -> Map.add t (commit::l) map
      in
      let f acc c =
        let (set,_,_) = of_commit c in
        Set.fold (add c) set acc
      in
      List.fold_left f Map.empty commits

    let issues_by_t issues =
      let add issue t map =
        match Map.find_opt t map with
        | None -> Map.add t [issue] map
        | Some l -> Map.add t (issue::l) map
      in
      let f acc i =
        let set = of_issue i in
        Set.fold (add i) set acc
      in
      List.fold_left f Map.empty issues
  end

module Smap = Statocaml.Smap

let subsys_map_wrapper w = Ocf.Wrapper.string_map
  ~fold:Smap.fold ~add:Smap.add ~empty:Smap.empty w

type re = Re.re

let re_wrapper =
  let to_json ?with_doc re =
    ignore(with_doc, re);
    failwith "No to_json fun for regexp" in
  let from_json ?def = function
  | `String s -> ignore(def); Re.(compile (Pcre.re s))
  | json -> Ocf.invalid_value json
  in
  Ocf.Wrapper.make to_json from_json

type subsys = {
    label: string [@ocf Ocf.Wrapper.string, ""] ;
    color : string [@ocf Ocf.Wrapper.string, "red"] ;
  } [@@ocf]

type rule = {
    re_path: re list [@ocf Ocf.Wrapper.list re_wrapper, []] ;
    ids: string list [@ocf Ocf.Wrapper.(list string), []] ;
  } [@@ocf]

type desc = {
    subsystems: subsys Smap.t [@ocf subsys_map_wrapper subsys_wrapper, Smap.empty] ;
    rules: rule list [@ocf Ocf.Wrapper.list rule_wrapper, []] ;
} [@@ocf]

let from_file : string -> (module P) = fun file ->
    let json = Yojson.Safe.from_file file in
    let desc = desc_wrapper.Ocf.Wrapper.from_json json in
    let compare = String.compare in
    let res_match res name =
      List.exists (fun re -> Re.exec_opt re name <> None) res
    in
    let warned = ref Statocaml.Sset.empty in
    let first_of_rules =
      let rec iter name = function
      | [] ->
          if not (Statocaml.Sset.mem name !warned) then
            (warned := Statocaml.Sset.add name !warned;
             Statocaml.Log.warn (fun m -> m "%S not ignored and not associated to a subsystem" name)
            );
          []
      | rule :: q ->
          if res_match rule.re_path name then
            rule.ids
          else
            iter name q
      in
      fun name -> iter name
    in
    let list_of_filename file = first_of_rules file desc.rules in
    let list_of_label _label = [] in

    let get id =
      match Smap.find_opt id desc.subsystems with
      | None -> failwith (Printf.sprintf "Unknown subsytem id %S" id)
      | Some s -> s
    in
    let module P =
  struct
    type t = string
    let compare = compare
    let to_string id = (get id).label
    let list = List.map fst (Smap.bindings desc.subsystems)
    let list_of_filename = list_of_filename
    let list_of_label = list_of_label
    let to_dot_color id = (get id).color
  end
    in
    (module P : P)

module Empty : P =
  struct
    type t = string
    let to_string x = x
    let list = []
    let compare = String.compare
    let list_of_filename _ = []
    let list_of_label _ = []
    let to_dot_color _ = "#000000"
  end
let empty = (module Empty : P)