diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index 824b325b..676dfb3b 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -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:[""; !input ]; + Nj.rule "copy" + ~command:[ "cp"; "-f"; !input; !output ] + ~description:[""; !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 diff --git a/compiler/catala_utils/cli.ml b/compiler/catala_utils/cli.ml index 1700859c..3bdac78d 100644 --- a/compiler/catala_utils/cli.ml +++ b/compiler/catala_utils/cli.ml @@ -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 = @{%s@}, and @{--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." diff --git a/compiler/catala_utils/cli.mli b/compiler/catala_utils/cli.mli index 0266e867..1c155189 100644 --- a/compiler/catala_utils/cli.mli +++ b/compiler/catala_utils/cli.mli @@ -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} *) diff --git a/compiler/driver.ml b/compiler/driver.ml index 8378019b..d5f9306e 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -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 diff --git a/compiler/driver.mli b/compiler/driver.mli index 1931e4dc..f37f7013 100644 --- a/compiler/driver.mli +++ b/compiler/driver.mli @@ -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] *)