CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

Clerk: copy files to _build and run catala there

Browse Source 
this is more consistent, avoids empty stamp files and should make things simpler
overall.

The slightly tricky `-C` option is added to Catala so that it can be run from
_build while paths to source and destination files are still specified relative
to CWD (Ninja doesn't provide string manipulation, so otherwise we would have to
explicit both the `_build/dir/` and `dir/` versions of each path).
This commit is contained in:
Louis Gesbert 2023-09-27 11:01:43 +02:00
parent 5efa61a0ce
commit 50fad76df3
5 changed files with 136 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
build_system/clerk_driver.ml
View File

@ -375,7 +375,8 @@ module Var = struct
end
let base_bindings catala_exe catala_flags =
[
let catala_flags = "-C" :: Var.(!builddir) :: catala_flags
in [
Nj.binding Var.ninja_required_version ["1.7"];
(* use of implicit outputs *)
Nj.binding Var.builddir [Lazy.force Poll.build_dir];
@ -401,11 +402,11 @@ let base_bindings catala_exe catala_flags =
let static_base_rules =
let open Var in
[
Nj.rule "stamp"
~command:[ "touch"; !output ]
~description:["<stamp>"; !input ];
Nj.rule "copy"
~command:[ "cp"; "-f"; !input; !output ]
~description:["<copy>"; !input ];
Nj.rule "ocaml"
Nj.rule "catala-ocaml"
~command:
[
!catala_exe;
@ -460,7 +461,6 @@ let static_base_rules =
!clerk_exe;
"runtest";
!clerk_flags;
"--build-dir=" ^ !builddir;
!input;
">"; !output;
"2>&1";
@ -473,7 +473,6 @@ let static_base_rules =
!catala_exe;
"interpret";
!catala_flags;
"--build-dir=" ^ !builddir;
!input;
"--scope=" ^ !scope;
]
@ -486,17 +485,18 @@ let gen_build_statements (item : Scan.item) : Nj.ninja =
let ( ! ) = Var.( ! ) in
let src = item.file_name in
let modules = List.rev item.used_modules in
let inc x = File.(!Var.builddir / x ^ "@inc") in
let inc x = File.(!Var.builddir / x) in
let modd x = File.(!Var.builddir / src /../ x ^ "@mod") in
let def_src =
Nj.binding Var.src [Filename.remove_extension src]
in
let srcv = !Var.src ^ Filename.extension src in
let include_deps =
Nj.build "stamp"
~inputs:(!Var.catala_exe :: srcv ::
List.map inc item.included_files @
List.map modd modules)
Nj.build "copy"
~inputs:[srcv]
~implicit_in:
(List.map inc item.included_files @
List.map modd modules)
~outputs:[inc srcv]
in
let module_deps =
@ -509,22 +509,22 @@ let gen_build_statements (item : Scan.item) : Nj.ninja =
let ml_file =
match item.module_def with
| Some m ->
!Var.builddir / src /../ m ^ ".ml"
src /../ m ^ ".ml"
| None ->
!Var.builddir / !Var.src ^ ".ml"
!Var.src ^ ".ml"
in
let ocaml =
Nj.build "ocaml" ~inputs:[srcv]
~implicit_in:[inc srcv]
~outputs:[ml_file]
Nj.build "catala-ocaml" ~inputs:[inc srcv]
~implicit_in:[!Var.catala_exe]
~outputs:[!Var.builddir / ml_file]
in
let ocamlopt =
let implicit_out_exts = ["cmi"; "cmx"; (* "cmt"; "o" *)] in
let implicit_out_exts = ["cmi"; "cmx"; "cmt"; "o"] in
match item.module_def with
| Some m ->
let target ext = !Var.builddir / src /../ m ^ "." ^ ext in
Nj.build "ocaml-module"
~inputs:[ml_file]
~inputs:[!Var.builddir / ml_file]
~implicit_in:(List.map (fun m -> !Var.builddir / src /../ m ^ ".cmi") modules)
~outputs:[target "cmxs"]
~implicit_out:(List.map target implicit_out_exts)
@ -540,12 +540,12 @@ let gen_build_statements (item : Scan.item) : Nj.ninja =
~implicit_out:(List.map target implicit_out_exts)
in
let interp_deps =
inc srcv :: List.map (fun m -> !Var.builddir /src /../ m ^ ".cmxs") modules
!Var.catala_exe :: List.map (fun m -> !Var.builddir /src /../ m ^ ".cmxs") modules
in
let interpret =
Nj.build "interpret"
~outputs:["interpret@" ^ srcv]
~inputs:[srcv]
~inputs:[inc srcv]
~implicit_in:interp_deps
in
let tests =
@ -558,8 +558,11 @@ let gen_build_statements (item : Scan.item) : Nj.ninja =
Var.test_command, test.Scan.cmd;
]
in
Nj.build "out-test" ~inputs:[srcv] ~implicit_in:(interp_deps @ [!Var.test_reference])
(* The test reference is an implicit input because of the cases when we run diff;
it should actually be an implicit output for the cases when we reset. *)
Nj.build "out-test" ~inputs:[inc srcv] ~implicit_in:(interp_deps @ [!Var.test_reference])
~outputs:[!Var.builddir / src /../ "output" / Filename.basename src -.- test.id]
(* ~implicit_out:[!Var.test_reference] *)
~vars
:: acc)
[] item.legacy_tests
@ -568,7 +571,10 @@ let gen_build_statements (item : Scan.item) : Nj.ninja =
if not item.has_inline_tests then []
else
[
Nj.build "inline-tests" ~inputs:[srcv] ~implicit_in:(!Var.clerk_exe :: interp_deps)
(* Same remark as for legacy, but here the reference is [srcv] *)
Nj.build "inline-tests" ~inputs:[inc srcv]
~implicit_in:(!Var.clerk_exe :: srcv :: interp_deps)
(* ~implicit_out:[srcv] *)
~outputs:[!Var.builddir / srcv ^ "@out"];
]
in

75
compiler/catala_utils/cli.ml
View File

@ -19,6 +19,8 @@
type file = string
type raw_file = file
type backend_lang = En | Fr | Pl
type when_enum = Auto | Always | Never
type message_format_enum = Human | GNU
@ -49,6 +51,7 @@ type options = {
mutable plugins_dirs : file list;
mutable disable_warnings : bool;
mutable max_prec_digits : int;
mutable path_rewrite : raw_file -> file;
}
(* Note: we force that the global options (ie options common to all commands)
@ -67,6 +70,7 @@ let globals =
plugins_dirs = [];
disable_warnings = false;
max_prec_digits = 20;
path_rewrite = (fun _ -> assert false);
}
let enforce_globals
@ -79,6 +83,7 @@ let enforce_globals
?plugins_dirs
?disable_warnings
?max_prec_digits
?path_rewrite
() =
Option.iter (fun x -> globals.input_src <- x) input_src;
Option.iter (fun x -> globals.language <- x) language;
@ -89,6 +94,7 @@ let enforce_globals
Option.iter (fun x -> globals.plugins_dirs <- x) plugins_dirs;
Option.iter (fun x -> globals.disable_warnings <- x) disable_warnings;
Option.iter (fun x -> globals.max_prec_digits <- x) max_prec_digits;
Option.iter (fun x -> globals.path_rewrite <- x) path_rewrite;
globals
open Cmdliner
@ -114,6 +120,29 @@ let file_lang filename =
@{<yellow>%s@}, and @{<bold>--language@} was not specified"
filename)
(** If [to_dir] is a path to a given directory and [f] a path to a file as seen from absolute path [from_dir], [reverse_path ~from_dir ~to_dir f] is a path leading to [f] from [to_dir]. The results attempts to be relative to [to_dir]. *)
let reverse_path ?(from_dir=Sys.getcwd()) ~to_dir f =
if Filename.is_relative from_dir then invalid_arg "File.with_reverse_path" else
if not (Filename.is_relative f) then f else
if not (Filename.is_relative to_dir) then Filename.concat from_dir f else
let rec aux acc rbase = function
| [] -> acc
| dir :: p ->
if dir = Filename.parent_dir_name then match rbase with
| base1 :: rbase -> aux (base1 :: acc) rbase p
| [] -> aux acc [] p
else
match acc with
| dir1 :: acc when dir1 = dir -> aux acc rbase p
| _ -> aux (Filename.parent_dir_name :: acc) rbase p
in
let path_to_list path =
String.split_on_char Filename.dir_sep.[0] path
|> List.filter (function "" | "." -> false | _ -> true)
in
let rbase = List.rev (path_to_list (from_dir)) in
String.concat Filename.dir_sep (aux (path_to_list f) rbase (path_to_list to_dir))
(** CLI flags and options *)
module Flags = struct
@ -235,6 +264,12 @@ module Flags = struct
& info ["name"] ~docv:"FILE"
~doc:"Treat the input as coming from a file with the given name. Useful e.g. when reading from stdin"
let directory =
value
& opt (some dir) None
& info ["C"; "directory"] ~docv:"DIR"
~doc:"Behave as if run from the given directory for file and error reporting. Does not affect resolution of files in arguments."
let flags =
let make
language
@ -244,12 +279,20 @@ module Flags = struct
trace
plugins_dirs
disable_warnings
max_prec_digits: options =
max_prec_digits
directory: options =
if debug then Printexc.record_backtrace true;
let path_rewrite =
match directory with
| None -> fun f -> f
| Some to_dir -> function
| "-" -> "-"
| f -> reverse_path ~to_dir f
in
(* This sets some global refs for convenience, but most importantly
returns the options record. *)
enforce_globals ~language ~debug ~color ~message_format ~trace
~plugins_dirs ~disable_warnings ~max_prec_digits ()
~plugins_dirs ~disable_warnings ~max_prec_digits ~path_rewrite ()
in
Term.(
const make
@ -260,10 +303,11 @@ module Flags = struct
$ trace
$ plugins_dirs
$ disable_warnings
$ max_prec_digits)
$ max_prec_digits
$ directory)
let options =
let make input_src name options : options =
let make input_src name directory options : options =
(* Set some global refs for convenience *)
let input_src =
match name with
@ -274,10 +318,19 @@ module Flags = struct
| Contents (str, _) -> Contents (str, name)
| Stdin _ -> Stdin name
in
let input_src =
match input_src with
| FileName f -> FileName (options.path_rewrite f)
| Contents (str, f) -> Contents (str, (options.path_rewrite f))
| Stdin f -> Stdin (options.path_rewrite f)
in
let plugins_dirs = List.map options.path_rewrite options.plugins_dirs in
Option.iter Sys.chdir directory;
globals.input_src <- input_src;
{ options with input_src }
globals.plugins_dirs <- plugins_dirs;
{ options with input_src; plugins_dirs }
in
Term.(const make $ input_src $ name_flag $ flags)
Term.(const make $ input_src $ name_flag $ directory $ flags)
end
let include_dirs =
@ -325,11 +378,11 @@ module Flags = struct
value
& opt (some string) None
& info ["output"; "o"] ~docv:"OUTPUT"
~env:(Cmd.Env.info "CATALA_OUT")
~doc:
"$(i, OUTPUT) is the file that will contain the output of the \
compiler. Defaults to $(i,FILE).$(i,EXT) where $(i,EXT) depends on \
the chosen backend. Use $(b,-o -) for stdout."
~env:(Cmd.Env.info "CATALA_OUT")
~doc:
"$(i, OUTPUT) is the file that will contain the output of the \
compiler. Defaults to $(i,FILE).$(i,EXT) where $(i,EXT) depends on \
the chosen backend. Use $(b,-o -) for stdout."
let optimize =
value & flag & info ["optimize"; "O"] ~doc:"Run compiler optimizations."

11
compiler/catala_utils/cli.mli
View File

@ -18,6 +18,9 @@
type file = string
(** File names ; equal to [File.t] but let's avoid cyclic dependencies *)
type raw_file
(** A file name that has not yet been resolved, [options.path_rewrite] must be called on it *)
type backend_lang = En | Fr | Pl
(** The usual auto/always/never option argument *)
@ -58,6 +61,7 @@ type options = private {
mutable plugins_dirs : string list;
mutable disable_warnings : bool;
mutable max_prec_digits : int;
mutable path_rewrite : raw_file -> file;
}
(** Global options, common to all subcommands (note: the fields are internally
mutable only for purposes of the [globals] toplevel value defined below) *)
@ -77,6 +81,7 @@ val enforce_globals :
?plugins_dirs:string list ->
?disable_warnings:bool ->
?max_prec_digits:int ->
?path_rewrite:(file -> file) ->
unit ->
options
(** Sets up the global options (side-effect); for specific use-cases only, this
@ -108,13 +113,13 @@ module Flags : sig
val ex_scope : string Term.t
val ex_scope_opt : string option Term.t
val ex_variable : string Term.t
val output : string option Term.t
val output : raw_file option Term.t
val optimize : bool Term.t
val avoid_exceptions : bool Term.t
val closure_conversion : bool Term.t
val include_dirs : string list Term.t
val include_dirs : raw_file list Term.t
val disable_counterexamples : bool Term.t
val build_dirs : string list Term.t
val build_dirs : raw_file list Term.t
end
(** {2 Command-line application} *)

53
compiler/driver.ml
View File

@ -26,8 +26,13 @@ let modname_of_file f =
(* Fixme: make this more robust *)
String.capitalize_ascii Filename.(basename (remove_extension f))
let load_module_interfaces includes program =
let load_module_interfaces options includes program =
(* Recurse into program modules, looking up files in [using] and loading them *)
let includes =
includes
|> List.map (fun d -> File.Tree.build (options.Cli.path_rewrite d))
|> List.fold_left File.Tree.union File.Tree.empty
in
let err_req_pos chain =
List.map (fun m -> Some "Module required from", ModuleName.pos m) chain
in
@ -67,7 +72,7 @@ let load_module_interfaces includes program =
let rec aux req_chain acc modules =
List.fold_left (fun acc mname ->
let m = ModuleName.of_string mname in
if List.mem_assoc m acc then acc else
if List.exists (fun (m1, _) -> ModuleName.equal m m1) acc then acc else
let f = find_module req_chain m in
let (m', intf), using = load_file f in
if not (ModuleName.equal m m') then
@ -101,7 +106,7 @@ module Passes = struct
Surface.Parser_driver.parse_top_level_file options.Cli.input_src
in
let prg = Surface.Fill_positions.fill_pos_with_legislative_info prg in
load_module_interfaces includes prg
load_module_interfaces options includes prg
let desugared options ~includes :
Desugared.Ast.program * Desugared.Name_resolution.context =
@ -338,24 +343,18 @@ module Commands = struct
second_part first_part ScopeName.format scope_uid)
second_part )
let include_flags =
let mk dirs =
dirs
|> List.map (fun d -> File.Tree.build d)
|> List.fold_left File.Tree.union File.Tree.empty
in
Term.(const mk $ Cli.Flags.include_dirs)
let get_output ?ext options output_file =
let output_file = Option.map options.Cli.path_rewrite output_file in
File.get_out_channel ~source_file:options.Cli.input_src ~output_file ?ext
()
let get_output_format ?ext options output_file =
let output_file = Option.map options.Cli.path_rewrite output_file in
File.get_formatter_of_out_channel ~source_file:options.Cli.input_src
~output_file ?ext ()
let makefile options output =
let prg = Passes.surface options ~includes:File.Tree.empty in
let prg = Passes.surface options ~includes:[] in
let backend_extensions_list = [".tex"] in
let source_file = Cli.input_src_file options.Cli.input_src in
let output_file, with_output = get_output options ~ext:".d" output in
@ -381,7 +380,7 @@ module Commands = struct
Term.(const makefile $ Cli.Flags.Global.options $ Cli.Flags.output)
let html options output print_only_law wrap_weaved_output =
let prg = Passes.surface options ~includes:File.Tree.empty in
let prg = Passes.surface options ~includes:[] in
Message.emit_debug "Weaving literate program into HTML";
let output_file, with_output =
get_output_format options ~ext:".html" output
@ -410,7 +409,7 @@ module Commands = struct
$ Cli.Flags.wrap_weaved_output)
let latex options output print_only_law wrap_weaved_output =
let prg = Passes.surface options ~includes:File.Tree.empty in
let prg = Passes.surface options ~includes:[] in
Message.emit_debug "Weaving literate program into LaTeX";
let output_file, with_output =
get_output_format options ~ext:".tex" output
@ -457,7 +456,7 @@ module Commands = struct
Term.(
const exceptions
$ Cli.Flags.Global.options
$ include_flags
$ Cli.Flags.include_dirs
$ Cli.Flags.ex_scope
$ Cli.Flags.ex_variable)
@ -486,7 +485,7 @@ module Commands = struct
Term.(
const scopelang
$ Cli.Flags.Global.options
$ include_flags
$ Cli.Flags.include_dirs
$ Cli.Flags.output
$ Cli.Flags.ex_scope_opt)
@ -509,7 +508,7 @@ module Commands = struct
Cmd.v
(Cmd.info "typecheck"
~doc:"Parses and typechecks a Catala program, without interpreting it.")
Term.(const typecheck $ Cli.Flags.Global.options $ include_flags)
Term.(const typecheck $ Cli.Flags.Global.options $ Cli.Flags.include_dirs)
let dcalc options includes output optimize ex_scope_opt check_invariants =
let prg, ctx, _ =
@ -550,7 +549,7 @@ module Commands = struct
Term.(
const dcalc
$ Cli.Flags.Global.options
$ include_flags
$ Cli.Flags.include_dirs
$ Cli.Flags.output
$ Cli.Flags.optimize
$ Cli.Flags.ex_scope_opt
@ -582,7 +581,7 @@ module Commands = struct
Term.(
const proof
$ Cli.Flags.Global.options
$ include_flags
$ Cli.Flags.include_dirs
$ Cli.Flags.optimize
$ Cli.Flags.ex_scope_opt
$ Cli.Flags.check_invariants
@ -613,6 +612,7 @@ module Commands = struct
results
let interpret_dcalc options includes optimize check_invariants build_dirs ex_scope =
let build_dirs = List.map options.Cli.path_rewrite build_dirs in
let prg, ctx, _ =
Passes.dcalc options ~includes ~optimize ~check_invariants
in
@ -630,7 +630,7 @@ module Commands = struct
Term.(
const interpret_dcalc
$ Cli.Flags.Global.options
$ include_flags
$ Cli.Flags.include_dirs
$ Cli.Flags.optimize
$ Cli.Flags.check_invariants
$ Cli.Flags.build_dirs
@ -672,7 +672,7 @@ module Commands = struct
Term.(
const lcalc
$ Cli.Flags.Global.options
$ include_flags
$ Cli.Flags.include_dirs
$ Cli.Flags.output
$ Cli.Flags.optimize
$ Cli.Flags.check_invariants
@ -689,6 +689,7 @@ module Commands = struct
closure_conversion
build_dirs
ex_scope =
let build_dirs = List.map options.Cli.path_rewrite build_dirs in
let prg, ctx, _ =
Passes.lcalc options ~includes ~optimize ~check_invariants
~avoid_exceptions ~closure_conversion
@ -707,7 +708,7 @@ module Commands = struct
Term.(
const interpret_lcalc
$ Cli.Flags.Global.options
$ include_flags
$ Cli.Flags.include_dirs
$ Cli.Flags.optimize
$ Cli.Flags.check_invariants
$ Cli.Flags.avoid_exceptions
@ -744,7 +745,7 @@ module Commands = struct
Term.(
const ocaml
$ Cli.Flags.Global.options
$ include_flags
$ Cli.Flags.include_dirs
$ Cli.Flags.output
$ Cli.Flags.optimize
$ Cli.Flags.check_invariants
@ -790,7 +791,7 @@ module Commands = struct
Term.(
const scalc
$ Cli.Flags.Global.options
$ include_flags
$ Cli.Flags.include_dirs
$ Cli.Flags.output
$ Cli.Flags.optimize
$ Cli.Flags.check_invariants
@ -827,7 +828,7 @@ module Commands = struct
Term.(
const python
$ Cli.Flags.Global.options
$ include_flags
$ Cli.Flags.include_dirs
$ Cli.Flags.output
$ Cli.Flags.optimize
$ Cli.Flags.check_invariants
@ -853,7 +854,7 @@ module Commands = struct
Term.(
const r
$ Cli.Flags.Global.options
$ include_flags
$ Cli.Flags.include_dirs
$ Cli.Flags.output
$ Cli.Flags.optimize
$ Cli.Flags.check_invariants

18
compiler/driver.mli
View File

@ -27,24 +27,24 @@ val main : unit -> unit
module Passes : sig
val surface :
Cli.options ->
includes:File.Tree.t ->
includes:Cli.raw_file list ->
Surface.Ast.program
val desugared :
Cli.options ->
includes:File.Tree.t ->
includes:Cli.raw_file list ->
Desugared.Ast.program * Desugared.Name_resolution.context
val scopelang :
Cli.options ->
includes:File.Tree.t ->
includes:Cli.raw_file list ->
Shared_ast.untyped Scopelang.Ast.program
* Desugared.Name_resolution.context
* Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t
val dcalc :
Cli.options ->
includes:File.Tree.t ->
includes:Cli.raw_file list ->
optimize:bool ->
check_invariants:bool ->
Shared_ast.typed Dcalc.Ast.program
@ -53,7 +53,7 @@ module Passes : sig
val lcalc :
Cli.options ->
includes:File.Tree.t ->
includes:Cli.raw_file list ->
optimize:bool ->
check_invariants:bool ->
avoid_exceptions:bool ->
@ -64,7 +64,7 @@ module Passes : sig
val scalc :
Cli.options ->
includes:File.Tree.t ->
includes:Cli.raw_file list ->
optimize:bool ->
check_invariants:bool ->
avoid_exceptions:bool ->
@ -80,14 +80,14 @@ module Commands : sig
val get_output :
?ext:string ->
Cli.options ->
string option ->
Cli.raw_file option ->
string option * ((out_channel -> 'a) -> 'a)
(** bounded open of the expected output file *)
val get_output_format :
?ext:string ->
Cli.options ->
string option ->
Cli.raw_file option ->
string option * ((Format.formatter -> 'a) -> 'a)
val get_scope_uid :
@ -99,8 +99,6 @@ module Commands : sig
string ->
Desugared.Ast.ScopeDef.t
val include_flags : File.Tree.t Cmdliner.Term.t
val commands : unit Cmdliner.Cmd.t list
(** The list of built-in catala subcommands, as expected by
[Cmdliner.Cmd.group] *)