mirror of
https://github.com/CatalaLang/catala.git
synced 2024-11-08 07:51:43 +03:00
Reformat
This commit is contained in:
Louis Gesbert
parent
ce17d8e563
commit
a79acd1fa8
@ -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 =
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 *)
|
||||
|
||||
@ -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 *)
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 =
|
||||
|
||||
@ -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 =
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ->
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ->
|
||||
|
||||
@ -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
|
||||
()
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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 *)
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user