Source file clerk_config.ml

(* This file is part of the Catala build system, a specification language for
   tax and social benefits computation rules. Copyright (C) 2024 Inria,
   contributors: Louis Gesbert <louis.gesbert@inria.fr>

   Licensed under the Apache License, Version 2.0 (the "License"); you may not
   use this file except in compliance with the License. You may obtain a copy of
   the License at

   http://www.apache.org/licenses/LICENSE-2.0

   Unless required by applicable law or agreed to in writing, software
   distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
   WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
   License for the specific language governing permissions and limitations under
   the License. *)

open Catala_utils
open Otoml

type backend = ..

let registered_backends = ref []

let register_backend ~name backend =
  registered_backends := (name, backend) :: !registered_backends

let registered_backends () = !registered_backends

let backend_name bk =
  let name, _ = List.find (fun (_, bk1) -> bk = bk1) (registered_backends ()) in
  name

type doc_backend = Html | Latex

type global = {
  project_name : string option;
  include_dirs : File.t list;
  exclude_dirs : File.t list;
  build_dir : File.t;
  target_dir : File.t;
  catala_exe : File.t option;
  catala_opts : string list;
  default_targets : string list;
  include_sources : bool;
}

type target = {
  tname : string;
  tmodules : string list;
  ttests : File.t list;
  backends : backend list;
  dependencies : string list;
}

type doc = {
  name : string;
  kind : doc_backend;
  entrypoints : string list;
  doc_options : string list;
}

type custom_rule = {
  backend : backend;
  in_exts : string list;
  out_exts : string list;
  commandline : string list;
}

type config_file = {
  global : global;
  variables : (string * string list) list;
  targets : target list;
  docs : doc list;
  custom_rules : custom_rule list;
}

type t = config_file

let default_global =
  {
    project_name = None;
    include_dirs = [Filename.current_dir_name];
    exclude_dirs = [];
    catala_exe = None;
    catala_opts = [];
    default_targets = [];
    build_dir = "_build";
    target_dir = "_targets";
    include_sources = true;
  }

let default_config =
  {
    global = default_global;
    variables = [];
    targets = [];
    docs = [];
    custom_rules = [];
  }

let project_encoding () =
  let open Clerk_toml_encoding in
  conv
    (fun {
           project_name;
           include_dirs;
           exclude_dirs;
           catala_exe;
           catala_opts;
           default_targets;
           build_dir;
           target_dir;
           include_sources;
         } ->
      ( project_name,
        (if include_dirs = default_global.include_dirs then None
         else Some include_dirs),
        proj_empty_list exclude_dirs,
        catala_exe,
        proj_empty_list catala_opts,
        proj_empty_list default_targets,
        build_dir,
        target_dir,
        include_sources ))
    (fun ( project_name,
           include_dirs,
           exclude_dirs,
           catala_exe,
           catala_opts,
           default_targets,
           build_dir,
           target_dir,
           include_sources )
       ->
      {
        project_name;
        include_dirs =
          (match include_dirs with
          | None -> default_global.include_dirs
          | Some l -> l);
        exclude_dirs = inj_empty_list exclude_dirs;
        catala_exe;
        catala_opts = inj_empty_list catala_opts;
        default_targets = inj_empty_list default_targets;
        build_dir;
        target_dir;
        include_sources;
      })
  @@ obj9
       (opt_field ~name:"name" @@ string)
       (opt_field ~name:"include_dirs" @@ list string)
       (opt_field ~name:"exclude_dirs" @@ list string)
       (opt_field ~name:"catala_exe" @@ string)
       (opt_field ~name:"catala_opts" @@ list string)
       (opt_field ~name:"default_targets" @@ list string)
       (dft_field ~name:"build_dir" ~default:default_global.build_dir string)
       (dft_field ~name:"target_dir" ~default:default_global.target_dir string)
       (dft_field ~name:"include_sources"
          ~default:default_global.include_sources bool)

let target_encoding () =
  let open Clerk_toml_encoding in
  conv
    (fun { tname; tmodules; ttests; backends; dependencies } ->
      tname, tmodules, ttests, backends, dependencies)
    (fun (tname, tmodules, ttests, backends, dependencies) ->
      { tname; tmodules; ttests; backends; dependencies })
  @@ obj5
       (req_field ~name:"name" @@ string)
       (req_field ~name:"modules" @@ list string)
       (dft_field ~name:"tests" ~default:[] @@ list string)
       (dft_field ~name:"backends"
          ~default:(registered_backends () |> List.map snd)
       @@ list (union (string_cases (registered_backends ()))))
       (dft_field ~name:"dependencies" ~default:[] @@ list string)

let doc_encoding () =
  let open Clerk_toml_encoding in
  conv
    (fun { name; entrypoints; kind; doc_options } ->
      name, entrypoints, kind, proj_empty_list doc_options)
    (fun (name, entrypoints, kind, doc_options) ->
      { name; entrypoints; kind; doc_options = inj_empty_list doc_options })
  @@ obj4
       (req_field ~name:"name" @@ string)
       (req_field ~name:"entrypoints" @@ list string)
       (req_field ~name:"kind"
       @@ union (string_cases ["latex", Latex; "html", Html]))
       (opt_field ~name:"doc_options" @@ list string)

let custom_rule_encoding () =
  let open Clerk_toml_encoding in
  conv
    (fun { backend; in_exts; out_exts; commandline } ->
      backend, in_exts, out_exts, commandline)
    (fun (backend, in_exts, out_exts, commandline) ->
      { backend; in_exts; out_exts; commandline })
  @@ obj4
       (req_field ~name:"backend"
       @@ union (string_cases (registered_backends ())))
       (req_field ~name:"in_exts" @@ list string)
       (req_field ~name:"out_exts" @@ list string)
       (req_field ~name:"commandline" @@ list string)

let variables_encoding () = Clerk_toml_encoding.(binding_list (list string))

let raw_config_encoding () =
  let open Clerk_toml_encoding in
  table5
    (table_opt ~name:"project" (project_encoding ()))
    (table_opt ~name:"variables" (variables_encoding ()))
    (multi_table ~name:"target" (target_encoding ()))
    (multi_table ~name:"doc" (doc_encoding ()))
    (multi_table ~name:"rule" (custom_rule_encoding ()))

let config_encoding () : config_file Clerk_toml_encoding.t =
  let open Clerk_toml_encoding in
  convt
    (fun { global; variables; targets; docs; custom_rules } ->
      Some global, proj_empty_list variables, targets, docs, custom_rules)
    (fun (global, variables, targets, docs, custom_rules) ->
      {
        global = Option.value global ~default:default_global;
        variables = inj_empty_list variables;
        targets;
        docs;
        custom_rules;
      })
  @@ raw_config_encoding ()

let pp_target_names fmt ts =
  Format.(
    pp_print_list
      ~pp_sep:(fun fmt () -> fprintf fmt ",@ ")
      (fun fmt tname -> fprintf fmt "@{<cyan>[%s]@}" tname))
    fmt ts

let validate path (config : config_file) : unit =
  let pp_clerk_toml ppf =
    let path = File.clean_path path in
    Message.pp_link ~target:(Message.file_url path) ppf "%a" File.format path
  in
  let _, dups =
    List.fold_left
      (fun (s, dups) { tname; _ } ->
        if String.Set.mem tname s then s, String.Set.add tname dups
        else String.Set.add tname s, dups)
      (String.Set.empty, String.Set.empty)
      config.targets
  in
  if not (String.Set.is_empty dups) then
    Message.error "In %t: multiple targets with a same name:@ %a" pp_clerk_toml
      pp_target_names (String.Set.elements dups);
  let missing_targets =
    List.filter (fun dft ->
        not (List.exists (fun t -> t.tname = dft) config.targets))
  in
  let missing_defaults = missing_targets config.global.default_targets in
  if missing_defaults <> [] then
    Message.error
      "In %t: unknown targets @{<yellow>%a@} in @{<cyan>default-targets@}"
      pp_clerk_toml
      (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_string)
      missing_defaults;
  List.iter
    (fun t ->
      let missing_deps = missing_targets t.dependencies in
      if missing_deps <> [] then
        Message.error
          "In %t: unknown targets @{<yellow>%a@} in dependencies of \
           @{<yellow>%s@}"
          pp_clerk_toml
          (Format.pp_print_list ~pp_sep:Format.pp_print_space
             Format.pp_print_string)
          missing_deps t.tname)
    config.targets

let read f =
  let toml =
    try Parser.from_file f
    with Parse_error (Some (li, col), msg) ->
      Message.error
        ~pos:(Pos.from_info f li col li (col + 1))
        "Error in Clerk configuration:@ %a" Format.pp_print_text msg
  in
  let config = Clerk_toml_encoding.decode toml (config_encoding ()) in
  validate f config;
  config

let write f config =
  let toml = Clerk_toml_encoding.encode config (config_encoding ()) in
  File.with_out_channel ~bin:false f @@ fun oc -> Printer.to_channel oc toml