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

Reformat

Browse Source
This commit is contained in:
Louis Gesbert 2023-09-27 13:06:30 +02:00
parent ce17d8e563
commit a79acd1fa8
19 changed files with 300 additions and 304 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

229
build_system/clerk_driver.ml
View File

@ -46,7 +46,7 @@ module Cli = struct
value
& opt string "_build"
& info ["build-dir"] ~docv:"DIR"
~doc:"Directory where compilation artifacts should be written")
~doc:"Directory where compilation artifacts should be written")
module Global : sig
val term :
@ -87,7 +87,9 @@ module Cli = struct
& info ["o"; "output"] ~docv:"FILE"
~doc:
"$(i,FILE) is the file that will contain the build.ninja file \
output. If not specified, the build.ninja file is set to $(i,<builddir>/clerk.ninja) in debug mode, and a temporary file otherwise")
output. If not specified, the build.ninja file is set to \
$(i,<builddir>/clerk.ninja) in debug mode, and a temporary file \
otherwise")
let term f =
Term.(
@ -228,14 +230,18 @@ module Poll = struct
else
match Lazy.force catala_project_root with
| Some root ->
Unix.realpath File.(root / "_build" / "default" / "compiler" / "catala.exe")
Unix.realpath
File.(root / "_build" / "default" / "compiler" / "catala.exe")
| None ->
Unix.realpath @@
File.process_out
~check_exit:(function 0 -> () | _ ->
Message.raise_error
"Could not find the @{<yellow>catala@} program, please fix your installation")
"command" ["-v"; "catala"])
Unix.realpath
@@ File.process_out
~check_exit:(function
| 0 -> ()
| _ ->
Message.raise_error
"Could not find the @{<yellow>catala@} program, please \
fix your installation")
"command" ["-v"; "catala"])
let build_dir : File.t Lazy.t = lazy "_build"
(* Note: it could be safer here to use File.(Sys.getcwd () / "_build"), but
@ -374,8 +380,8 @@ module Var = struct
end
let base_bindings catala_exe catala_flags =
let catala_flags = ("--directory=" ^ Var.(!builddir)) :: catala_flags
in [
let catala_flags = ("--directory=" ^ 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];
@ -402,30 +408,14 @@ let static_base_rules =
let open Var in
[
Nj.rule "copy"
~command:[ "cp"; "-f"; !input; !output ]
~description:["<copy>"; !input ];
~command:["cp"; "-f"; !input; !output]
~description:["<copy>"; !input];
Nj.rule "catala-ocaml"
~command:
[
!catala_exe;
"ocaml";
!catala_flags;
!input;
"-o";
!output;
]
~command:[!catala_exe; "ocaml"; !catala_flags; !input; "-o"; !output]
~description:["<catala>"; "ocaml"; "⇒"; !output];
Nj.rule "ocaml-module"
~command:
[
!ocamlopt_exe;
"-shared";
!ocamlopt_flags;
!input;
"-o";
!output;
]
[!ocamlopt_exe; "-shared"; !ocamlopt_flags; !input; "-o"; !output]
~description:["<ocaml>"; "⇒"; !output];
Nj.rule "ocaml-exec"
~command:
@ -455,28 +445,13 @@ let static_base_rules =
["<catala>"; "test"; !test_id; "⇐"; !input; "(" ^ !test_command ^ ")"];
Nj.rule "inline-tests"
~command:
[
!clerk_exe;
"runtest";
!clerk_flags;
!input;
">"; !output;
"2>&1";
]
[!clerk_exe; "runtest"; !clerk_flags; !input; ">"; !output; "2>&1"]
~description:["<catala>"; "inline-tests"; "⇐"; !input];
Nj.rule "post-test"
~command:
[!post_test; !input]
Nj.rule "post-test" ~command:[!post_test; !input]
~description:["<test-validation>"];
Nj.rule "interpret"
~command:
[
!catala_exe;
"interpret";
!catala_flags;
!input;
"--scope=" ^ !scope;
]
[!catala_exe; "interpret"; !catala_flags; !input; "--scope=" ^ !scope]
~description:["<catala>"; "interpret"; !scope; "⇐"; !input]
~vars:[pool, ["console"]];
]
@ -488,34 +463,26 @@ let gen_build_statements (item : Scan.item) : Nj.ninja =
let modules = List.rev item.used_modules in
let inc x = File.(!Var.builddir / x) in
let modd x = "module@" ^ File.(src /../ x) in
let def_src =
Nj.binding Var.src [Filename.remove_extension src]
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 "copy"
~inputs:[srcv]
~implicit_in:
(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 =
Option.map (fun m ->
Nj.build "phony"
~inputs:[inc srcv]
~outputs:[modd m]
) item.module_def
Option.map
(fun m -> Nj.build "phony" ~inputs:[inc srcv] ~outputs:[modd m])
item.module_def
in
let ml_file =
match item.module_def with
| Some m ->
src /../ m ^ ".ml"
| None ->
!Var.src ^ ".ml"
| Some m -> (src /../ m) ^ ".ml"
| None -> !Var.src ^ ".ml"
in
let ocaml =
Nj.build "catala-ocaml" ~inputs:[inc srcv]
Nj.build "catala-ocaml"
~inputs:[inc srcv]
~implicit_in:[!Var.catala_exe]
~outputs:[!Var.builddir / ml_file]
in
@ -523,25 +490,31 @@ let gen_build_statements (item : Scan.item) : Nj.ninja =
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
let target ext = (!Var.builddir / src /../ m) ^ "." ^ ext in
Nj.build "ocaml-module"
~inputs:[!Var.builddir / ml_file]
~implicit_in:(List.map (fun m -> !Var.builddir / src /../ m ^ ".cmi") modules)
~implicit_in:
(List.map (fun m -> (!Var.builddir / src /../ m) ^ ".cmi") modules)
~outputs:[target "cmxs"]
~implicit_out:(List.map target implicit_out_exts)
~vars:[Var.ocamlopt_flags,
[ !Var.ocamlopt_flags; "-I" ; File.(!Var.builddir / src /../ "") ]]
~vars:
[
( Var.ocamlopt_flags,
[!Var.ocamlopt_flags; "-I"; File.(!Var.builddir / src /../ "")] );
]
| None ->
let target ext = !Var.builddir / !Var.src ^"."^ ext in
let target ext = (!Var.builddir / !Var.src) ^ "." ^ ext in
let inputs =
List.map (fun m -> !Var.builddir / src /../ m ^ ".cmx") modules
List.map (fun m -> (!Var.builddir / src /../ m) ^ ".cmx") modules
@ [ml_file]
in
Nj.build "ocaml-exec" ~inputs ~outputs:[target "exe"]
Nj.build "ocaml-exec" ~inputs
~outputs:[target "exe"]
~implicit_out:(List.map target implicit_out_exts)
in
let interp_deps =
!Var.catala_exe :: 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"
@ -550,37 +523,39 @@ let gen_build_statements (item : Scan.item) : Nj.ninja =
~implicit_in:interp_deps
in
let legacy_test_reference test =
src /../ "output" / Filename.basename src -.- test.Scan.id
(src /../ "output" / Filename.basename src) -.- test.Scan.id
in
let tests =
let legacy_tests =
List.fold_left
(fun acc test ->
let vars = [
Var.test_id, [test.Scan.id];
Var.test_command, test.Scan.cmd;
]
in
let reference = legacy_test_reference test in
let test_out = !Var.builddir / src /../ "output" / Filename.basename src -.- test.id in
Nj.build "out-test" ~inputs:[inc srcv] ~implicit_in:interp_deps
~outputs:[test_out]
~vars ::
(* The test reference is an input because of the cases when we run diff;
it should actually be an output for the cases when we reset but that shouldn't cause trouble. *)
Nj.build "post-test"
~inputs:[reference; test_out]
~outputs:["post@" ^ reference]
:: acc)
let vars =
[Var.test_id, [test.Scan.id]; Var.test_command, test.Scan.cmd]
in
let reference = legacy_test_reference test in
let test_out =
(!Var.builddir / src /../ "output" / Filename.basename src)
-.- test.id
in
Nj.build "out-test"
~inputs:[inc srcv]
~implicit_in:interp_deps ~outputs:[test_out] ~vars
:: (* The test reference is an input because of the cases when we run
diff; it should actually be an output for the cases when we
reset but that shouldn't cause trouble. *)
Nj.build "post-test" ~inputs:[reference; test_out]
~outputs:["post@" ^ reference]
:: acc)
[] item.legacy_tests
in
let inline_tests =
if not item.has_inline_tests then []
else
[
Nj.build "inline-tests" ~inputs:[inc srcv]
Nj.build "inline-tests"
~inputs:[inc srcv]
~implicit_in:(!Var.clerk_exe :: interp_deps)
~outputs:[!Var.builddir / srcv ^ "@out"];
~outputs:[(!Var.builddir / srcv) ^ "@out"];
]
in
let tests =
@ -590,14 +565,18 @@ let gen_build_statements (item : Scan.item) : Nj.ninja =
~outputs:["test@" ^ srcv]
~inputs:[srcv; inc (srcv ^ "@out")]
~implicit_in:
(List.map (fun test -> "post@" ^ legacy_test_reference test) item.legacy_tests);
(List.map
(fun test -> "post@" ^ legacy_test_reference test)
item.legacy_tests);
]
else if item.legacy_tests <> [] then
[
Nj.build "phony"
~outputs:["test@" ^ srcv]
~inputs:
(List.map (fun test -> "post@" ^ legacy_test_reference test) item.legacy_tests)
(List.map
(fun test -> "post@" ^ legacy_test_reference test)
item.legacy_tests);
]
else []
in
@ -622,10 +601,7 @@ let test_targets_by_dir items =
~outputs:[target_pfx ^ dir]
~inputs:(List.map (( ^ ) target_pfx) sub)
in
let alias dir sub =
List.to_seq
[stmt "test@" dir sub; Nj.comment ""]
in
let alias dir sub = List.to_seq [stmt "test@" dir sub; Nj.comment ""] in
(* This relies on the fact that the sequence is returned ordered by
directory *)
let rec aux curdir seq =
@ -633,10 +609,12 @@ let test_targets_by_dir items =
match seq () with
| Seq.Cons (item, seq) as node
when String.starts_with ~prefix item.Scan.file_name -> (
if item.Scan.legacy_tests = [] && not item.Scan.has_inline_tests then aux curdir seq
if item.Scan.legacy_tests = [] && not item.Scan.has_inline_tests then
aux curdir seq
else
match
String.split_on_char '/' (String.remove_prefix ~prefix item.Scan.file_name)
String.split_on_char '/'
(String.remove_prefix ~prefix item.Scan.file_name)
with
| [] -> assert false
| [_] ->
@ -695,10 +673,8 @@ let ninja_init ~chdir ~catala_exe ~catala_opts ~color ~debug ~ninja_output :
let with_ninja_output k =
match ninja_output with
| Some f -> k f
| None when debug ->
k File.(Lazy.force Poll.build_dir / "clerk.ninja")
| None ->
File.with_temp_file "clerk_build_" ".ninja" k
| None when debug -> k File.(Lazy.force Poll.build_dir / "clerk.ninja")
| None -> File.with_temp_file "clerk_build_" ".ninja" k
in
fun ~extra k ->
Message.emit_debug "building ninja rules...";
@ -719,12 +695,14 @@ let ninja_init ~chdir ~catala_exe ~catala_opts ~color ~debug ~ninja_output :
let ninja_cmdline ninja_flags nin_file targets =
String.concat " "
("ninja" :: "-k" :: "0" ::
"-f" :: nin_file ::
(if ninja_flags = "" then [] else [ninja_flags]) @
(if Catala_utils.Cli.globals.debug then ["-v"] else [])
@ targets)
("ninja"
:: "-k"
:: "0"
:: "-f"
:: nin_file
:: (if ninja_flags = "" then [] else [ninja_flags])
@ (if Catala_utils.Cli.globals.debug then ["-v"] else [])
@ targets)
open Cmdliner
@ -755,15 +733,20 @@ let test_cmd =
| [] -> ["test"]
| files -> List.map (fun f -> "test@" ^ f) files
in
let extra = List.to_seq (
(if reset_test_outputs
then
[Nj.binding Var.post_test
["test_reset() { if ! diff -q $$1 $$2; then cp -f $$2 $$1; fi; }"; ";" ; "test_reset" ]]
else [])
@
[Nj.default targets]
)
let extra =
List.to_seq
((if reset_test_outputs then
[
Nj.binding Var.post_test
[
"test_reset() { if ! diff -q $$1 $$2; then cp -f $$2 $$1; \
fi; }";
";";
"test_reset";
];
]
else [])
@ [Nj.default targets])
in
ninja_init ~extra
@@ fun nin_file ->
@ -821,9 +804,7 @@ let runtest_cmd =
let run catala_exe catala_opts build_dir file =
Clerk_runtest.run_inline_tests
(Option.value ~default:"catala" catala_exe)
catala_opts
build_dir
file;
catala_opts build_dir file;
0
in
let doc =

4
build_system/clerk_driver.mli
View File

@ -14,5 +14,5 @@
License for the specific language governing permissions and limitations under
the License. *)
val main_cmd: int Cmdliner.Cmd.t
val main: unit -> unit
val main_cmd : int Cmdliner.Cmd.t
val main : unit -> unit

45
build_system/clerk_runtest.ml
View File

@ -21,8 +21,8 @@ let run_catala_test catala_exe catala_opts build_dir file program args oc =
Unix.set_close_on_exec cmd_in_wr;
let command_oc = Unix.out_channel_of_descr cmd_in_wr in
let catala_exe =
(* If the exe name contains directories, make it absolute. Otherwise
don't modify it so that it can be looked up in PATH. *)
(* If the exe name contains directories, make it absolute. Otherwise don't
modify it so that it can be looked up in PATH. *)
if String.contains catala_exe Filename.dir_sep.[0] then
Unix.realpath catala_exe
else catala_exe
@ -31,25 +31,22 @@ let run_catala_test catala_exe catala_opts build_dir file program args oc =
match args with
| cmd0 :: flags ->
Array.of_list
((catala_exe :: cmd0 :: catala_opts) @ flags @ ["--name="^file; "-"])
((catala_exe :: cmd0 :: catala_opts) @ flags @ ["--name=" ^ file; "-"])
| [] -> Array.of_list ((catala_exe :: catala_opts) @ [file])
in
let env =
Unix.environment ()
|> Array.to_seq
|> Seq.filter (fun s ->
not (String.starts_with ~prefix:"OCAMLRUNPARAM=" s))
|> Seq.filter (fun s -> not (String.starts_with ~prefix:"OCAMLRUNPARAM=" s))
|> Seq.cons "CATALA_OUT=-"
(* |> Seq.cons "CATALA_COLOR=never" *)
|> Seq.cons "CATALA_PLUGINS="
|> Seq.cons ("CATALA_BUILD_DIR="^build_dir)
|> Seq.cons ("CATALA_BUILD_DIR=" ^ build_dir)
|> Array.of_seq
in
flush oc;
let ocfd = Unix.descr_of_out_channel oc in
let pid =
Unix.create_process_env catala_exe cmd env cmd_in_rd ocfd ocfd
in
let pid = Unix.create_process_env catala_exe cmd env cmd_in_rd ocfd ocfd in
Unix.close cmd_in_rd;
Queue.iter (output_string command_oc) program;
close_out command_oc;
@ -58,16 +55,18 @@ let run_catala_test catala_exe catala_opts build_dir file program args oc =
| _, Unix.WEXITED n -> n
| _, (Unix.WSIGNALED n | Unix.WSTOPPED n) -> 128 - n
in
if return_code <> 0 then
Printf.fprintf oc "#return code %d#\n" return_code
if return_code <> 0 then Printf.fprintf oc "#return code %d#\n" return_code
(** Directly runs the test (not using ninja, this will be called by ninja rules
through the "clerk runtest" command) *)
let run_inline_tests catala_exe catala_opts build_dir filename =
let module L = Surface.Lexer_common in
let lang = match Clerk_scan.get_lang filename with
let lang =
match Clerk_scan.get_lang filename with
| Some l -> l
| None -> Message.raise_error "Can't infer catala dialect from file extension of %a" File.format filename
| None ->
Message.raise_error "Can't infer catala dialect from file extension of %a"
File.format filename
in
let lines = Surface.Parser_driver.lines filename lang in
let oc = stdout in
@ -79,21 +78,26 @@ let run_inline_tests catala_exe catala_opts build_dir filename =
let rec run_test lines =
match Seq.uncons lines with
| None ->
output_string oc "[INVALID TEST] Missing test command, use '$ catala <args>'\n"
output_string oc
"[INVALID TEST] Missing test command, use '$ catala <args>'\n"
| Some ((str, L.LINE_BLOCK_END), lines) ->
output_string oc "[INVALID TEST] Missing test command, use '$ catala <args>'\n";
output_string oc
"[INVALID TEST] Missing test command, use '$ catala <args>'\n";
push str;
process lines
| Some ((str, _), lines) ->
| Some ((str, _), lines) -> (
push str;
match Clerk_scan.test_command_args str with
| None ->
output_string oc "[INVALID TEST] Invalid test command syntax, must match '$ catala <args>'\n";
output_string oc
"[INVALID TEST] Invalid test command syntax, must match '$ catala \
<args>'\n";
skip_block lines
| Some args ->
let args = String.split_on_char ' ' args in
run_catala_test catala_exe catala_opts build_dir filename lines_until_now args oc;
skip_block lines
run_catala_test catala_exe catala_opts build_dir filename
lines_until_now args oc;
skip_block lines)
and skip_block lines =
match Seq.uncons lines with
| None -> ()
@ -109,7 +113,8 @@ let run_inline_tests catala_exe catala_opts build_dir filename =
push str;
run_test lines
| Some ((str, _), lines) ->
push str; process lines
push str;
process lines
| None -> ()
in
process lines

24
build_system/clerk_scan.ml
View File

@ -40,22 +40,20 @@ let test_command_args =
let re =
compile
@@ seq
[
bos;
char '$';
rep space;
str "catala";
rep space;
group (rep1 notnl);
char '\n';
]
[
bos;
char '$';
rep space;
str "catala";
rep space;
group (rep1 notnl);
char '\n';
]
in
fun str ->
exec_opt re str |>
Option.map (fun g -> String.trim (Re.Group.get g 1))
exec_opt re str |> Option.map (fun g -> String.trim (Re.Group.get g 1))
let catala_file (file : File.t) (lang : Catala_utils.Cli.backend_lang) :
item =
let catala_file (file : File.t) (lang : Catala_utils.Cli.backend_lang) : item =
let module L = Surface.Lexer_common in
let rec parse lines n acc =
match Seq.uncons lines with

18
build_system/clerk_scan.mli
View File

@ -14,7 +14,9 @@
License for the specific language governing permissions and limitations under
the License. *)
(** This module is responsible for scanning Catala files, extracting dependency and test information. It is based on the lightweight "line-parser" ([Surface.Parser_driver.line]) *)
(** This module is responsible for scanning Catala files, extracting dependency
and test information. It is based on the lightweight "line-parser"
([Surface.Parser_driver.line]) *)
open Catala_utils
@ -43,14 +45,16 @@ type item = {
(** Contains all the data extracted from a single Catala file. Lists are in
reverse file order. *)
val get_lang: File.t -> Cli.backend_lang option
val get_lang : File.t -> Cli.backend_lang option
(** Guesses Catala dialect from file-name and global options *)
val catala_file: File.t -> Catala_utils.Cli.backend_lang -> item
val catala_file : File.t -> Catala_utils.Cli.backend_lang -> item
(** Scans a single Catala file into an item *)
val tree: File.t -> item Seq.t
(** Recursively scans a directory, and returns the corresponding items in sequence. *)
val tree : File.t -> item Seq.t
(** Recursively scans a directory, and returns the corresponding items in
sequence. *)
val test_command_args: string -> string option
(** Parses a test command-line (in the form "$ catala <args>") and returns the arguments as a string, or [None] if there is no match *)
val test_command_args : string -> string option
(** Parses a test command-line (in the form "$ catala <args>") and returns the
arguments as a string, or [None] if there is no match *)

78
compiler/catala_utils/cli.ml
View File

@ -18,16 +18,11 @@
(* Types used by flags & options *)
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
type input_src =
| FileName of file
| Contents of string * file
| Stdin of file
type input_src = FileName of file | Contents of string * file | Stdin of file
(** Associates a {!type: Cli.backend_lang} with its string represtation. *)
let languages = ["en", En; "fr", Fr; "pl", Pl]
@ -36,9 +31,7 @@ let language_code =
let rl = List.map (fun (a, b) -> b, a) languages in
fun l -> List.assoc l rl
let input_src_file = function
| FileName f | Contents (_, f) | Stdin f -> f
let input_src_file = function FileName f | Contents (_, f) | Stdin f -> f
let message_format_opt = ["human", Human; "gnu", GNU]
type options = {
@ -120,28 +113,34 @@ 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
(** 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
| 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
| _ -> 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))
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 *)
@ -156,8 +155,8 @@ module Flags = struct
let converter =
conv ~docv:"FILE"
( (fun s ->
if s = "-" then Ok (Stdin "-stdin-") else
Result.map (fun f -> FileName f) (conv_parser non_dir_file s)),
if s = "-" then Ok (Stdin "-stdin-")
else Result.map (fun f -> FileName f) (conv_parser non_dir_file s)),
fun ppf -> function
| Stdin _ -> Format.pp_print_string ppf "-"
| FileName f -> conv_printer non_dir_file ppf f
@ -262,13 +261,17 @@ module Flags = struct
value
& opt (some string) None
& info ["name"] ~docv:"FILE"
~doc:"Treat the input as coming from a file with the given name. Useful e.g. when reading from stdin"
~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."
~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
@ -280,14 +283,13 @@ module Flags = struct
plugins_dirs
disable_warnings
max_prec_digits
directory: options =
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
| 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. *)
@ -312,16 +314,16 @@ module Flags = struct
let input_src =
match name with
| None -> input_src
| Some name ->
| Some name -> (
match input_src with
| FileName f -> FileName f
| Contents (str, _) -> Contents (str, name)
| Stdin _ -> Stdin 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))
| 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
@ -336,9 +338,8 @@ module Flags = struct
let include_dirs =
value
& opt_all string []
& info ["I";"include"] ~docv:"DIR"
~doc:
"Include directory to lookup for compiled module files."
& info ["I"; "include"] ~docv:"DIR"
~doc:"Include directory to lookup for compiled module files."
let check_invariants =
value
@ -378,11 +379,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."
@ -410,7 +411,6 @@ module Flags = struct
"Disables the search for counterexamples. Useful when you want a \
deterministic output from the Catala compiler, since provers can \
have some randomness in them."
end
(* Retrieve current version from dune *)

15
compiler/catala_utils/cli.mli
View File

@ -19,7 +19,8 @@ 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 *)
(** A file name that has not yet been resolved, [options.path_rewrite] must be
called on it *)
type backend_lang = En | Fr | Pl
@ -34,18 +35,22 @@ type message_format_enum =
(** Sources for program input *)
type input_src =
| FileName of file (** A file path to read from disk *)
| Contents of string * file (** A raw string containing the code, and the corresponding (fake) filename *)
| Stdin of file (** Read from stdin; the specified filename will be used for file lookups, error reportings, etc. *)
| FileName of file (** A file path to read from disk *)
| Contents of string * file
(** A raw string containing the code, and the corresponding (fake)
filename *)
| Stdin of file
(** Read from stdin; the specified filename will be used for file lookups,
error reportings, etc. *)
val languages : (string * backend_lang) list
val language_code : backend_lang -> string
(** Returns the lowercase two-letter language code *)
val file_lang : file -> backend_lang
(** Associates a file extension with its corresponding {!type: Cli.backend_lang}
string representation. *)
val file_lang : file -> backend_lang
val input_src_file : input_src -> file

32
compiler/catala_utils/file.ml
View File

@ -120,8 +120,8 @@ let check_file f =
with Unix.Unix_error _ | Sys_error _ -> None
let ( / ) a b =
if a = "" || a = Filename.current_dir_name then b
else Filename.concat a b
if a = "" || a = Filename.current_dir_name then b else Filename.concat a b
let dirname = Filename.dirname
let ( /../ ) a b = dirname a / b
let ( -.- ) file ext = Filename.chop_extension file ^ "." ^ ext
@ -183,24 +183,24 @@ module Tree = struct
let empty = lazy Map.empty
let rec build path = lazy
(Array.fold_left
(fun m f ->
let path = path / f in
match Sys.is_directory path with
| true -> Map.add f (path, D (build path)) m
| false -> Map.add f (path, F) m
| exception Sys_error _ -> m)
Map.empty
(Sys.readdir path))
let rec build path =
lazy
(Array.fold_left
(fun m f ->
let path = path / f in
match Sys.is_directory path with
| true -> Map.add f (path, D (build path)) m
| false -> Map.add f (path, F) m
| exception Sys_error _ -> m)
Map.empty (Sys.readdir path))
let subtree t path =
let rec aux t = function
| [] -> t
| dir :: path ->
| dir :: path -> (
match Map.find_opt dir (Lazy.force t) with
| Some (_, D sub) -> aux sub path
| Some (_, F) | None -> raise Not_found
| Some (_, F) | None -> raise Not_found)
in
aux t (path_to_list path)
@ -212,6 +212,6 @@ module Tree = struct
| Some (_, D _) | None -> None
with Not_found -> None
let union t1 t2 = lazy (Map.union (fun _ x _ -> Some x) (Lazy.force t1) (Lazy.force t2))
let union t1 t2 =
lazy (Map.union (fun _ x _ -> Some x) (Lazy.force t1) (Lazy.force t2))
end

39
compiler/catala_utils/file.mli
View File

@ -86,11 +86,13 @@ val check_directory : t -> t option
[Unix.realpath]). *)
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]. *)
(** Returns its argument if it exists and is a plain file, [None] otherwise.
Does not do resolution like [check_directory]. *)
val ( / ) : t -> t -> t
(** [Filename.concat]: Sugar to allow writing
[File.("some" / "relative" / "path")]. As an exception, if the lhs is [.], returns the rhs unchanged. *)
[File.("some" / "relative" / "path")]. As an exception, if the lhs is [.],
returns the rhs unchanged. *)
val dirname : t -> t
(** [Filename.dirname], re-exported for convenience *)
@ -120,28 +122,33 @@ val scan_tree : (t -> 'a option) -> t -> 'a Seq.t
or "_*" are ignored. Unreadable files or subdirectories are ignored with a
debug message. If [t] is a plain file, scan just that non-recursively. *)
module Tree: sig
(** A lazy tree structure mirroring the filesystem ; uses the comparison from File, so paths are case-insensitive. *)
module Tree : sig
(** A lazy tree structure mirroring the filesystem ; uses the comparison from
File, so paths are case-insensitive. *)
type path = t (** Alias for [File.t] *)
type path = t
(** Alias for [File.t] *)
type item = F (** Plain file *) | D of t (** Directory with subtree *)
type item =
| F (** Plain file *)
| D of t (** Directory with subtree *)
and t = (path * item) Map.t Lazy.t
(** Contents of a directory, lazily loaded. The map keys are the basenames of the files and subdirectories, while the values contain the original path (with correct capitalisation) *)
(** Contents of a directory, lazily loaded. The map keys are the basenames of
the files and subdirectories, while the values contain the original path
(with correct capitalisation) *)
val empty: t
val empty : t
val build: path -> t
(** Lazily builds a [Tree.path] from the files read at [path]. The names in the maps are qualified (i.e. they all start with ["path/"]) *)
val build : path -> t
(** Lazily builds a [Tree.path] from the files read at [path]. The names in
the maps are qualified (i.e. they all start with ["path/"]) *)
val subtree: t -> path -> t
val subtree : t -> path -> t
(** Looks up a path within a lazy tree *)
val lookup: t -> path -> path option
(** Checks if there is a matching plain file (case-insensitively) ; and returns its path with the correct case if so *)
val lookup : t -> path -> path option
(** Checks if there is a matching plain file (case-insensitively) ; and
returns its path with the correct case if so *)
val union: t -> t -> t
val union : t -> t -> t
(** Merges two trees. In case of conflict, lhs entry wins *)
end

4
compiler/catala_utils/pos.ml
View File

@ -146,14 +146,14 @@ let format_loc_text ppf (pos : t) =
| None -> None
in
None, input_line_opt
| None ->
| None -> (
try
let ic = open_in filename in
let input_line_opt () : string option =
try Some (input_line ic) with End_of_file -> None
in
Some ic, input_line_opt
with Sys_error _ -> None, (fun () -> None)
with Sys_error _ -> None, fun () -> None)
in
let include_extra_count = 0 in
let rec get_lines (n : int) : (int * string) list =

3
compiler/catala_web_interpreter.ml
View File

@ -19,7 +19,8 @@ let () =
Message.raise_error "Unrecognised input locale %S" language
in
let options =
Cli.enforce_globals ~input_src:(Contents (contents, "-inline-"))
Cli.enforce_globals
~input_src:(Contents (contents, "-inline-"))
~language:(Some language) ~debug:false ~color:Never ~trace ()
in
let prg, ctx, _type_order =

6
compiler/desugared/from_surface.ml
View File

@ -1529,11 +1529,11 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) :
| S.CodeBlock (block, _, _) -> process_code_block ctxt prgm block
| S.ModuleDef ((name, pos) as mname) ->
let file = Filename.basename (Pos.get_file pos) in
if not File.(equal name (Filename.remove_extension file))
then
if not File.(equal name (Filename.remove_extension file)) then
Message.raise_spanned_error pos
"Module declared as %a, which does not match the file name %a"
ModuleName.format (ModuleName.of_string mname)
ModuleName.format
(ModuleName.of_string mname)
File.format file
else prgm
| S.LawInclude _ | S.LawText _ | S.ModuleUse _ -> prgm

42
compiler/driver.ml
View File

@ -27,7 +27,8 @@ let modname_of_file f =
String.capitalize_ascii Filename.(basename (remove_extension f))
let load_module_interfaces options includes program =
(* Recurse into program modules, looking up files in [using] and loading them *)
(* 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))
@ -45,21 +46,18 @@ let load_module_interfaces options includes program =
in
match
List.filter_map
(fun (ext, _) ->
File.Tree.lookup includes (fname_base ^ ext))
(fun (ext, _) -> File.Tree.lookup includes (fname_base ^ ext))
extensions
with
| [] ->
Message.raise_multispanned_error (err_req_pos (m::req_chain))
"Required module not found: %a"
ModuleName.format m
| [f] ->
f
Message.raise_multispanned_error
(err_req_pos (m :: req_chain))
"Required module not found: %a" ModuleName.format m
| [f] -> f
| ms ->
Message.raise_multispanned_error
(err_req_pos (m::req_chain))
"Required module %a matches multiple files: %a"
ModuleName.format m
(err_req_pos (m :: req_chain))
"Required module %a matches multiple files: %a" ModuleName.format m
(Format.pp_print_list ~pp_sep:Format.pp_print_space File.format)
ms
in
@ -70,27 +68,27 @@ let load_module_interfaces options includes program =
(ModuleName.of_string mname, intf), using
in
let rec aux req_chain acc modules =
List.fold_left (fun acc mname ->
List.fold_left
(fun acc mname ->
let m = ModuleName.of_string mname in
if List.exists (fun (m1, _) -> ModuleName.equal m m1) 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
Message.raise_multispanned_error
((Some "Module name declaration", ModuleName.pos m') ::
err_req_pos (m::req_chain))
((Some "Module name declaration", ModuleName.pos m')
:: err_req_pos (m :: req_chain))
"Mismatching module name declaration:";
let acc = (m', intf) :: acc in
aux (m::req_chain) acc using
)
aux (m :: req_chain) acc using)
acc modules
in
let program_modules =
aux [] [] (List.map fst program.Surface.Ast.program_modules)
|> List.map (fun (m, i) -> (m : ModuleName.t :> string Mark.pos), i)
in
{ program with
Surface.Ast.program_modules }
{ program with Surface.Ast.program_modules }
module Passes = struct
(* Each pass takes only its cli options, then calls upon its dependent passes
@ -345,8 +343,7 @@ module Commands = struct
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
()
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
@ -830,8 +827,7 @@ module Commands = struct
$ Cli.Flags.avoid_exceptions
$ Cli.Flags.closure_conversion)
let r options includes output optimize check_invariants closure_conversion
=
let r options includes output optimize check_invariants closure_conversion =
let prg, _, type_ordering =
Passes.scalc options ~includes ~optimize ~check_invariants
~avoid_exceptions:false ~closure_conversion

5
compiler/driver.mli
View File

@ -25,10 +25,7 @@ val main : unit -> unit
Each pass takes only its cli options, then calls upon its dependent passes
(forwarding their options as needed) *)
module Passes : sig
val surface :
Cli.options ->
includes:Cli.raw_file list ->
Surface.Ast.program
val surface : Cli.options -> includes:Cli.raw_file list -> Surface.Ast.program
val desugared :
Cli.options ->

2
compiler/plugin.ml
View File

@ -55,7 +55,7 @@ let load_dir d =
| false ->
if List.exists (Filename.check_suffix f) dynlink_exts then
load_file f
| exception (Sys_error _) -> ())
| exception Sys_error _ -> ())
(Sys.readdir d)
in
aux d

5
compiler/plugins/explain.ml
View File

@ -1416,7 +1416,10 @@ let run includes optimize ex_scope explain_options global_options =
| { output; _ } ->
let _, with_out = Driver.Commands.get_output global_options output in
with_out (fun oc -> output_string oc dot_content);
fun f -> f (Option.value ~default:"-" (Option.map Cli.globals.path_rewrite output))
fun f ->
f
(Option.value ~default:"-"
(Option.map Cli.globals.path_rewrite output))
in
with_dot_file
@@ fun dotfile ->

21
compiler/shared_ast/interpreter.ml
View File

@ -943,25 +943,30 @@ let evaluate_expr ctx lang e = delcustom (evaluate_expr ctx lang (addcustom e))
let load_runtime_modules prg =
let load m =
let obj_file =
Dynlink.adapt_filename File.(Pos.get_file (ModuleName.pos m) /../ ModuleName.to_string m ^ ".cmo")
Dynlink.adapt_filename
File.(
(Pos.get_file (ModuleName.pos m) /../ ModuleName.to_string m) ^ ".cmo")
in
if not (Sys.file_exists obj_file) then
Message.raise_spanned_error
~span_msg:(fun ppf -> Format.pp_print_string ppf "Module defined here")
(ModuleName.pos m)
"Compiled OCaml object %a not found. Make sure it has been suitably compiled." File.format obj_file
"Compiled OCaml object %a not found. Make sure it has been suitably \
compiled."
File.format obj_file
else
try Dynlink.loadfile obj_file
with Dynlink.Error dl_err ->
Message.raise_error
"Error loading compiled module from %a:@;\
<1 2>@[<hov>%a@]" File.format obj_file
Format.pp_print_text
"Error loading compiled module from %a:@;<1 2>@[<hov>%a@]" File.format
obj_file Format.pp_print_text
(Dynlink.error_message dl_err)
in
let rec aux loaded decl_ctx =
ModuleName.Map.fold (fun mname sub_decl_ctx loaded ->
if ModuleName.Set.mem mname loaded then loaded else
ModuleName.Map.fold
(fun mname sub_decl_ctx loaded ->
if ModuleName.Set.mem mname loaded then loaded
else
let loaded = ModuleName.Set.add mname loaded in
let loaded = aux loaded sub_decl_ctx in
load mname;
@ -972,5 +977,5 @@ let load_runtime_modules prg =
Message.emit_debug "Loading shared modules... %a"
(fun ppf -> ModuleName.Map.format_keys ppf)
prg.decl_ctx.ctx_modules;
let (_loaded: ModuleName.Set.t) = aux ModuleName.Set.empty prg.decl_ctx in
let (_loaded : ModuleName.Set.t) = aux ModuleName.Set.empty prg.decl_ctx in
()

29
compiler/surface/parser_driver.ml
View File

@ -241,9 +241,7 @@ let with_sedlex_file file f =
Fun.protect ~finally:(fun () -> close_in ic) (fun () -> f lexbuf)
(** Parses a single source file *)
let rec parse_source
(lexbuf: Sedlexing.lexbuf)
: Ast.program =
let rec parse_source (lexbuf : Sedlexing.lexbuf) : Ast.program =
let source_file_name = lexbuf_file lexbuf in
Message.emit_debug "Parsing %a" File.format source_file_name;
let language = Cli.file_lang source_file_name in
@ -259,9 +257,8 @@ let rec parse_source
(** Expands the include directives in a parsing result, thus parsing new source
files *)
and expand_includes
(source_file : string)
(commands : Ast.law_structure list) : Ast.program =
and expand_includes (source_file : string) (commands : Ast.law_structure list) :
Ast.program =
let language = Cli.file_lang source_file in
let rprg =
List.fold_left
@ -270,8 +267,10 @@ and expand_includes
| Ast.ModuleDef id -> (
match acc.Ast.program_module_name with
| None ->
{ acc with Ast.program_module_name = Some id;
Ast.program_items = command :: acc.Ast.program_items;
{
acc with
Ast.program_module_name = Some id;
Ast.program_items = command :: acc.Ast.program_items;
}
| Some id2 ->
Message.raise_multispanned_error
@ -286,7 +285,8 @@ and expand_includes
| Ast.LawInclude (Ast.CatalaFile inc_file) ->
let source_dir = Filename.dirname source_file in
let sub_source = File.(source_dir / Mark.remove inc_file) in
with_sedlex_file sub_source @@ fun lexbuf ->
with_sedlex_file sub_source
@@ fun lexbuf ->
let includ_program = parse_source lexbuf in
let () =
includ_program.Ast.program_module_name
@ -390,9 +390,7 @@ let with_sedlex_source source_file f =
f lexbuf
let load_interface source_file =
let program =
with_sedlex_source source_file parse_source
in
let program = with_sedlex_source source_file parse_source in
let modname =
match program.Ast.program_module_name with
| Some mname -> mname
@ -410,11 +408,8 @@ let load_interface source_file =
let used_modules, intf = get_interface program in
(modname, intf), used_modules
let parse_top_level_file
(source_file : Cli.input_src)
: Ast.program =
let program =
with_sedlex_source source_file parse_source in
let parse_top_level_file (source_file : Cli.input_src) : Ast.program =
let program = with_sedlex_source source_file parse_source in
{
program with
Ast.program_items = law_struct_list_to_tree program.Ast.program_items;

3
compiler/surface/parser_driver.mli
View File

@ -24,8 +24,7 @@ val lines :
(** Raw file parser that doesn't interpret any includes and returns the flat law
structure as is *)
val load_interface :
Cli.input_src -> Ast.interface * string Mark.pos list
val load_interface : Cli.input_src -> Ast.interface * string Mark.pos list
(** Reads only declarations in metadata in the supplied input file, and only
keeps type information ; returns the modules used as well *)