From 05752988e6b4de5d983f0ae39fdc0540d5985b10 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Tue, 25 Jun 2024 18:29:42 +0200 Subject: [PATCH] Clerk: add support for basic configuration files Not much there at the moment, but being able to specify the include directories is already pretty useful to run clerk directly e.g. on `catala-examples`. (you had to explicitely specify variable `CATALA_INCLUDE`, the `-I` flags or to go through `make` without that) --- build_system/clerk_config.ml | 112 ++++++++++++++++++++++++++ build_system/clerk_config.mli | 27 +++++++ build_system/clerk_driver.ml | 142 +++++++++++++++++++-------------- build_system/dune | 5 +- catala.opam | 1 + compiler/catala_utils/file.ml | 16 ++++ compiler/catala_utils/file.mli | 9 +++ 7 files changed, 250 insertions(+), 62 deletions(-) create mode 100644 build_system/clerk_config.ml create mode 100644 build_system/clerk_config.mli diff --git a/build_system/clerk_config.ml b/build_system/clerk_config.ml new file mode 100644 index 00000000..9da0c98d --- /dev/null +++ b/build_system/clerk_config.ml @@ -0,0 +1,112 @@ +(* 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 + + 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 t = { + catala_opts : string list; + build_dir : File.t; + include_dirs : File.t list; +} + +let default = { catala_opts = []; build_dir = "_build"; include_dirs = [] } + +let toml_to_config toml = + { + catala_opts = Helpers.find_strings_exn toml ["build"; "catala_opts"]; + build_dir = Helpers.find_string_exn toml ["build"; "build_dir"]; + include_dirs = Helpers.find_strings_exn toml ["project"; "include_dirs"]; + } + +let config_to_toml t = + table + [ + ( "build", + table + [ + "catala_opts", array (List.map string t.catala_opts); + "build_dir", string t.build_dir; + ] ); + "project", table ["include_dirs", array (List.map string t.include_dirs)]; + ] + +let default_toml = config_to_toml default + +(* joins default and supplied conf, ensuring types match. The filename is for + error reporting *) +let rec join ?(rpath = []) fname t1 t2 = + match t1, t2 with + | TomlString _, TomlString _ + | TomlInteger _, TomlInteger _ + | TomlFloat _, TomlFloat _ + | TomlBoolean _, TomlBoolean _ + | TomlOffsetDateTime _, TomlOffsetDateTime _ + | TomlLocalDateTime _, TomlLocalDateTime _ + | TomlLocalDate _, TomlLocalDate _ + | TomlLocalTime _, TomlLocalTime _ + | TomlArray _, TomlArray _ + | TomlTableArray _, TomlTableArray _ -> + t2 + | TomlTable tt1, TomlTable tt2 | TomlInlineTable tt1, TomlInlineTable tt2 -> + let m1 = String.Map.of_list tt1 in + let m2 = String.Map.of_list tt2 in + TomlTable + (String.Map.merge + (fun key t1 t2 -> + match t1, t2 with + | None, Some _ -> + Message.error + "While parsing %a: invalid key @{%S@} at @{%s@}" + File.format fname key + (if rpath = [] then "file root" + else String.concat "." (List.rev rpath)) + | Some t1, Some t2 -> Some (join ~rpath:(key :: rpath) fname t1 t2) + | Some t1, None -> Some t1 + | None, None -> assert false) + m1 m2 + |> String.Map.bindings) + | _ -> + Message.error + "While parsing %a: Wrong type for config value @{%s@}, was \ + expecting @{%s@}" + File.format fname + (String.concat "." (List.rev rpath)) + (match t1 with + | TomlString _ -> "a string" + | TomlInteger _ -> "an integer" + | TomlFloat _ -> "a float" + | TomlBoolean _ -> "a boolean" + | TomlOffsetDateTime _ -> "an offsetdatetime" + | TomlLocalDateTime _ -> "a localdatetime" + | TomlLocalDate _ -> "a localdate" + | TomlLocalTime _ -> "a localtime" + | TomlArray _ | TomlTableArray _ -> "an array" + | TomlTable _ | TomlInlineTable _ -> "a table") + +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 + toml_to_config (join f default_toml toml) + +let write f t = + let toml = config_to_toml t in + File.with_out_channel f @@ fun oc -> Printer.to_channel oc toml diff --git a/build_system/clerk_config.mli b/build_system/clerk_config.mli new file mode 100644 index 00000000..9c52bc63 --- /dev/null +++ b/build_system/clerk_config.mli @@ -0,0 +1,27 @@ +(* 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 + + 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 + +type t = { + catala_opts : string list; + build_dir : File.t; + include_dirs : File.t list; +} + +val default : t +val read : File.t -> t +val write : File.t -> t -> unit diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index 9e7ab20f..74806051 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -1,7 +1,7 @@ (* This file is part of the Catala build system, a specification language for tax and social benefits computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux , Emile Rolley - + , Louis Gesbert 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 @@ -101,7 +101,7 @@ module Cli = struct val debug : bool Term.t val term : - (chdir:File.t option -> + (config_file:File.t option -> catala_exe:File.t option -> catala_opts:string list -> build_dir:File.t option -> @@ -112,12 +112,14 @@ module Cli = struct 'a) -> 'a Term.t end = struct - let chdir = + let config_file = Arg.( value - & opt (some string) None - & info ["C"] ~docv:"DIR" - ~doc:"Change to the given directory before processing") + & opt (some file) None + & info ["config"] ~docv:"FILE" + ~doc: + "Clerk configuration file to use, instead of looking up \ + \"clerk.toml\" in parent directories.") let color = Arg.( @@ -148,7 +150,7 @@ module Cli = struct Term.( const (fun - chdir + config_file catala_exe catala_opts build_dir @@ -157,9 +159,9 @@ module Cli = struct debug ninja_output -> - f ~chdir ~catala_exe ~catala_opts ~build_dir ~include_dirs ~color - ~debug ~ninja_output) - $ chdir + f ~config_file ~catala_exe ~catala_opts ~build_dir ~include_dirs + ~color ~debug ~ninja_output) + $ config_file $ catala_exe $ catala_opts $ build_dir @@ -300,36 +302,18 @@ end (** Some functions that poll the surrounding systems (think [./configure]) *) module Poll = struct - let project_root_absrel : (File.t option * File.t) Lazy.t = - lazy - (let open File in - let home = try Sys.getenv "HOME" with Not_found -> "" in - let rec lookup dir rel = - if - Sys.file_exists (dir / "catala.opam") - || Sys.file_exists (dir / ".git") - || Sys.file_exists (dir / "clerk.toml") - then Some dir, rel - else if dir = home then None, Filename.current_dir_name - else - let parent = Filename.dirname dir in - if parent = dir then None, Filename.current_dir_name - else lookup parent (rel / Filename.parent_dir_name) - in - lookup (Sys.getcwd ()) Filename.current_dir_name) - - let project_root = lazy (fst (Lazy.force project_root_absrel)) - let project_root_relative = lazy (snd (Lazy.force project_root_absrel)) + (** This module is sensitive to the CWD at first use. Therefore it's expected + that [chdir] has been run beforehand to the project root. *) + let root = lazy (Sys.getcwd ()) (** Scans for a parent directory being the root of the Catala source repo *) let catala_project_root : File.t option Lazy.t = - lazy - (match Lazy.force project_root with - | Some root - when Sys.file_exists File.(root / "catala.opam") - && Sys.file_exists File.(root / "dune-project") -> - Some root - | _ -> None) + root + |> Lazy.map + @@ fun root -> + if File.(exists (root / "catala.opam") && exists (root / "dune-project")) + then Some root + else None let exec_dir : File.t = Catala_utils.Cli.exec_dir let clerk_exe : File.t Lazy.t = lazy (Unix.realpath Sys.executable_name) @@ -339,14 +323,14 @@ module Poll = struct (let f = File.(exec_dir / "catala") in if Sys.file_exists f then Unix.realpath f else - match Lazy.force project_root with - | Some root when Sys.file_exists File.(root / "catala.opam") -> + match catala_project_root with + | (lazy (Some root)) -> Unix.realpath File.(root / "_build" / "default" / "compiler" / "catala.exe") | _ -> File.check_exec "catala") - let build_dir : ?dir:File.t -> unit -> File.t = - fun ?(dir = "_build") () -> + let build_dir : dir:File.t -> unit -> File.t = + fun ~dir () -> let d = File.clean_path dir in File.ensure_dir d; d @@ -434,14 +418,6 @@ module Poll = struct lazy (snd (Lazy.force ocaml_include_and_lib_flags)) end -(* Adjusts paths specified from the command-line relative to the user cwd to be - instead relative to the project root *) -let fix_path = - let from_dir = Sys.getcwd () in - fun d -> - let to_dir = Lazy.force Poll.project_root_relative in - Catala_utils.File.reverse_path ~from_dir ~to_dir d - (**{1 Building rules}*) (** Ninja variable names *) @@ -793,8 +769,10 @@ let gen_ninja_file catala_exe catala_flags build_dir include_dirs test_flags dir (** {1 Driver} *) +(* Last argument is a continuation taking as arguments [build_dir], the + [fix_path] function, and the ninja file name *) let ninja_init - ~chdir + ~config_file ~catala_exe ~catala_opts ~build_dir @@ -802,14 +780,58 @@ let ninja_init ~color ~debug ~ninja_output : - extra:def Seq.t -> test_flags:string list -> (File.t -> File.t -> 'a) -> 'a - = + extra:def Seq.t -> + test_flags:string list -> + (File.t -> (File.t -> File.t) -> File.t -> 'a) -> + 'a = let _options = Catala_utils.Global.enforce_options ~debug ~color () in - let chdir = - match chdir with None -> Lazy.force Poll.project_root | some -> some + let default_config_file = "clerk.toml" in + let set_root_dir dir = + Message.debug "Entering directory %a" File.format dir; + Sys.chdir dir in - Option.iter Sys.chdir chdir; - let build_dir = Poll.build_dir ?dir:build_dir () in + (* fix_path adjusts paths specified from the command-line relative to the user + cwd to be instead relative to the project root *) + let fix_path, config = + let from_dir = Sys.getcwd () in + match config_file with + | None -> ( + match + File.(find_in_parents (fun dir -> exists (dir / default_config_file))) + with + | Some (root, rel) -> + set_root_dir root; + ( Catala_utils.File.reverse_path ~from_dir ~to_dir:rel, + Clerk_config.read default_config_file ) + | None -> ( + match + File.( + find_in_parents (function dir -> + exists (dir / "catala.opam") || exists (dir / ".git"))) + with + | Some (root, rel) -> + set_root_dir root; + ( Catala_utils.File.reverse_path ~from_dir ~to_dir:rel, + Clerk_config.default ) + | None -> Fun.id, Clerk_config.default)) + | Some f -> + let root = Filename.dirname f in + let config = Clerk_config.read f in + set_root_dir root; + ( (fun d -> + let r = Catala_utils.File.reverse_path ~from_dir ~to_dir:root d in + Message.debug "%a => %a" File.format d File.format r; + r), + config ) + in + let build_dir = + let dir = + match build_dir with None -> config.build_dir | Some dir -> dir + in + Poll.build_dir ~dir () + in + let catala_opts = config.catala_opts @ catala_opts in + let include_dirs = config.include_dirs @ include_dirs in let with_ninja_output k = match ninja_output with | Some f -> k f @@ -837,7 +859,7 @@ let ninja_init ] in Nj.format nin_ppf ninja_contents); - k build_dir nin_file + k build_dir fix_path nin_file let cleaned_up_env () = let passthrough_vars = @@ -879,7 +901,7 @@ open Cmdliner let build_cmd = let run ninja_init (targets : string list) (ninja_flags : string list) = ninja_init ~extra:Seq.empty ~test_flags:[] - @@ fun _build_dir nin_file -> + @@ fun _build_dir fix_path nin_file -> let targets = List.map (fun f -> @@ -920,7 +942,7 @@ let test_cmd = set_report_verbosity verbosity; Clerk_report.set_display_flags ~use_patdiff (); ninja_init ~extra:Seq.empty ~test_flags - @@ fun build_dir nin_file -> + @@ fun build_dir fix_path nin_file -> let targets = let fs = if files_or_folders = [] then ["."] else files_or_folders in List.map File.(fun f -> (build_dir / fix_path f) ^ "@test") fs @@ -1005,7 +1027,7 @@ let run_cmd = (List.map (fun file -> file ^ "@interpret") files_or_folders))) in ninja_init ~extra ~test_flags:[] - @@ fun _build_dir nin_file -> + @@ fun _build_dir _fix_path nin_file -> let ninja_cmd = ninja_cmdline ninja_flags nin_file [] in Message.debug "executing '%s'..." (String.concat " " ninja_cmd); raise (Catala_utils.Cli.Exit_with (run_ninja ~clean_up_env:false ninja_cmd)) diff --git a/build_system/dune b/build_system/dune index 0296e25c..85b6f320 100644 --- a/build_system/dune +++ b/build_system/dune @@ -8,8 +8,9 @@ ninja_utils cmdliner re - ocolor) - (modules clerk_scan clerk_report clerk_runtest clerk_driver)) + ocolor + otoml) + (modules clerk_scan clerk_report clerk_runtest clerk_config clerk_driver)) (rule (target custom_linking.sexp) diff --git a/catala.opam b/catala.opam index 4650932f..687c00ec 100644 --- a/catala.opam +++ b/catala.opam @@ -51,6 +51,7 @@ depends: [ "conf-pandoc" {cataladevmode} "z3" {catalaz3mode} "conf-ninja" + "otoml" {>= "1.0"} ] depopts: ["z3"] conflicts: [ diff --git a/compiler/catala_utils/file.ml b/compiler/catala_utils/file.ml index 02fbe6f1..5bbe8f35 100644 --- a/compiler/catala_utils/file.ml +++ b/compiler/catala_utils/file.ml @@ -66,6 +66,8 @@ let clean_path p = in if p = "" then "." else p +let exists = Sys.file_exists + let rec ensure_dir dir = match Sys.is_directory dir with | true -> () @@ -104,6 +106,20 @@ let reverse_path ?(from_dir = Sys.getcwd ()) ~to_dir f = String.concat Filename.dir_sep (aux (path_to_list f) rbase (path_to_list to_dir)) +let find_in_parents predicate = + let home = try Sys.getenv "HOME" with Not_found -> "" in + let rec lookup dir rel = + if predicate dir then Some dir, rel + else if dir = home then None, Filename.current_dir_name + else + let parent = Filename.dirname dir in + if parent = dir then None, Filename.current_dir_name + else lookup parent (rel / Filename.parent_dir_name) + in + match lookup (Sys.getcwd ()) Filename.current_dir_name with + | Some dir, rel -> Some (dir, rel) + | None, _ -> None + let with_out_channel filename f = ensure_dir (Filename.dirname filename); let oc = open_out filename in diff --git a/compiler/catala_utils/file.mli b/compiler/catala_utils/file.mli index 688e86a2..725ae06f 100644 --- a/compiler/catala_utils/file.mli +++ b/compiler/catala_utils/file.mli @@ -89,6 +89,9 @@ val ensure_dir : t -> unit (** Creates the directory (and parents recursively) if it doesn't exist already. Errors out if the file exists but is not a directory *) +val exists : t -> bool +(** Alias for Sys.file_exists*) + val check_file : t -> t option (** Returns its argument if it exists and is a plain file, [None] otherwise. Does not do resolution like [check_directory]. *) @@ -122,6 +125,12 @@ val reverse_path : ?from_dir:t -> to_dir:t -> t -> t leading to [f] from [to_dir]. The results attempts to be relative to [to_dir]. *) +val find_in_parents : (t -> bool) -> (t * t) option +(** Checks for the first directory matching the given predicate from the current + directory upwards. Recursion stops at home. Returns a pair [dir, rel_path], + where [dir] is the ancestor directory matching the predicate, and [rel_path] + is a path pointing to it from the current dir. *) + val ( /../ ) : t -> t -> t (** Sugar for [parent a / b] *)