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

4
build_system/clerk_driver.mli
View File

@ -14,5 +14,5 @@
License for the specific language governing permissions and limitations under License for the specific language governing permissions and limitations under
the License. *) the License. *)
val main_cmd: int Cmdliner.Cmd.t val main_cmd : int Cmdliner.Cmd.t
val main: unit -> unit 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; Unix.set_close_on_exec cmd_in_wr;
let command_oc = Unix.out_channel_of_descr cmd_in_wr in let command_oc = Unix.out_channel_of_descr cmd_in_wr in
let catala_exe = let catala_exe =
(* If the exe name contains directories, make it absolute. Otherwise (* If the exe name contains directories, make it absolute. Otherwise don't
don't modify it so that it can be looked up in PATH. *) modify it so that it can be looked up in PATH. *)
if String.contains catala_exe Filename.dir_sep.[0] then if String.contains catala_exe Filename.dir_sep.[0] then
Unix.realpath catala_exe Unix.realpath catala_exe
else 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 match args with
| cmd0 :: flags -> | cmd0 :: flags ->
Array.of_list 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]) | [] -> Array.of_list ((catala_exe :: catala_opts) @ [file])
in in
let env = let env =
Unix.environment () Unix.environment ()
|> Array.to_seq |> Array.to_seq
|> Seq.filter (fun s -> |> Seq.filter (fun s -> not (String.starts_with ~prefix:"OCAMLRUNPARAM=" s))
not (String.starts_with ~prefix:"OCAMLRUNPARAM=" s))
|> Seq.cons "CATALA_OUT=-" |> Seq.cons "CATALA_OUT=-"
(* |> Seq.cons "CATALA_COLOR=never" *) (* |> Seq.cons "CATALA_COLOR=never" *)
|> Seq.cons "CATALA_PLUGINS=" |> Seq.cons "CATALA_PLUGINS="
|> Seq.cons ("CATALA_BUILD_DIR="^build_dir) |> Seq.cons ("CATALA_BUILD_DIR=" ^ build_dir)
|> Array.of_seq |> Array.of_seq
in in
flush oc; flush oc;
let ocfd = Unix.descr_of_out_channel oc in let ocfd = Unix.descr_of_out_channel oc in
let pid = let pid = Unix.create_process_env catala_exe cmd env cmd_in_rd ocfd ocfd in
Unix.create_process_env catala_exe cmd env cmd_in_rd ocfd ocfd
in
Unix.close cmd_in_rd; Unix.close cmd_in_rd;
Queue.iter (output_string command_oc) program; Queue.iter (output_string command_oc) program;
close_out command_oc; 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.WEXITED n -> n
| _, (Unix.WSIGNALED n | Unix.WSTOPPED n) -> 128 - n | _, (Unix.WSIGNALED n | Unix.WSTOPPED n) -> 128 - n
in in
if return_code <> 0 then if return_code <> 0 then Printf.fprintf oc "#return code %d#\n" return_code
Printf.fprintf oc "#return code %d#\n" return_code
(** Directly runs the test (not using ninja, this will be called by ninja rules (** Directly runs the test (not using ninja, this will be called by ninja rules
through the "clerk runtest" command) *) through the "clerk runtest" command) *)
let run_inline_tests catala_exe catala_opts build_dir filename = let run_inline_tests catala_exe catala_opts build_dir filename =
let module L = Surface.Lexer_common in 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 | 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 in
let lines = Surface.Parser_driver.lines filename lang in let lines = Surface.Parser_driver.lines filename lang in
let oc = stdout 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 = let rec run_test lines =
match Seq.uncons lines with match Seq.uncons lines with
| None -> | 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) -> | 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; push str;
process lines process lines
| Some ((str, _), lines) -> | Some ((str, _), lines) -> (
push str; push str;
match Clerk_scan.test_command_args str with match Clerk_scan.test_command_args str with
| None -> | 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 skip_block lines
| Some args -> | Some args ->
let args = String.split_on_char ' ' args in let args = String.split_on_char ' ' args in
run_catala_test catala_exe catala_opts build_dir filename lines_until_now args oc; run_catala_test catala_exe catala_opts build_dir filename
skip_block lines lines_until_now args oc;
skip_block lines)
and skip_block lines = and skip_block lines =
match Seq.uncons lines with match Seq.uncons lines with
| None -> () | None -> ()
@ -109,7 +113,8 @@ let run_inline_tests catala_exe catala_opts build_dir filename =
push str; push str;
run_test lines run_test lines
| Some ((str, _), lines) -> | Some ((str, _), lines) ->
push str; process lines push str;
process lines
| None -> () | None -> ()
in in
process lines process lines

24
build_system/clerk_scan.ml
View File

@ -40,22 +40,20 @@ let test_command_args =
let re = let re =
compile compile
@@ seq @@ seq
[ [
bos; bos;
char '$'; char '$';
rep space; rep space;
str "catala"; str "catala";
rep space; rep space;
group (rep1 notnl); group (rep1 notnl);
char '\n'; char '\n';
] ]
in in
fun str -> fun str ->
exec_opt re str |> exec_opt re str |> Option.map (fun g -> String.trim (Re.Group.get g 1))
Option.map (fun g -> String.trim (Re.Group.get g 1))
let catala_file (file : File.t) (lang : Catala_utils.Cli.backend_lang) : let catala_file (file : File.t) (lang : Catala_utils.Cli.backend_lang) : item =
item =
let module L = Surface.Lexer_common in let module L = Surface.Lexer_common in
let rec parse lines n acc = let rec parse lines n acc =
match Seq.uncons lines with 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 License for the specific language governing permissions and limitations under
the License. *) 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 open Catala_utils
@ -43,14 +45,16 @@ type item = {
(** Contains all the data extracted from a single Catala file. Lists are in (** Contains all the data extracted from a single Catala file. Lists are in
reverse file order. *) 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 *) (** 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 *) (** Scans a single Catala file into an item *)
val tree: File.t -> item Seq.t val tree : File.t -> item Seq.t
(** Recursively scans a directory, and returns the corresponding items in sequence. *) (** Recursively scans a directory, and returns the corresponding items in
sequence. *)
val test_command_args: string -> string option 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 *) (** 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 *) (* Types used by flags & options *)
type file = string type file = string
type raw_file = file type raw_file = file
type backend_lang = En | Fr | Pl type backend_lang = En | Fr | Pl
type when_enum = Auto | Always | Never type when_enum = Auto | Always | Never
type message_format_enum = Human | GNU type message_format_enum = Human | GNU
type input_src = type input_src = FileName of file | Contents of string * file | Stdin of file
| FileName of file
| Contents of string * file
| Stdin of file
(** Associates a {!type: Cli.backend_lang} with its string represtation. *) (** Associates a {!type: Cli.backend_lang} with its string represtation. *)
let languages = ["en", En; "fr", Fr; "pl", Pl] 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 let rl = List.map (fun (a, b) -> b, a) languages in
fun l -> List.assoc l rl fun l -> List.assoc l rl
let input_src_file = function let input_src_file = function FileName f | Contents (_, f) | Stdin f -> f
| FileName f | Contents (_, f) | Stdin f -> f
let message_format_opt = ["human", Human; "gnu", GNU] let message_format_opt = ["human", Human; "gnu", GNU]
type options = { type options = {
@ -120,28 +113,34 @@ let file_lang filename =
@{<yellow>%s@}, and @{<bold>--language@} was not specified" @{<yellow>%s@}, and @{<bold>--language@} was not specified"
filename) 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]. *) (** If [to_dir] is a path to a given directory and [f] a path to a file as seen
let reverse_path ?(from_dir=Sys.getcwd()) ~to_dir f = from absolute path [from_dir], [reverse_path ~from_dir ~to_dir f] is a path
if Filename.is_relative from_dir then invalid_arg "File.with_reverse_path" else leading to [f] from [to_dir]. The results attempts to be relative to
if not (Filename.is_relative f) then f else [to_dir]. *)
if not (Filename.is_relative to_dir) then Filename.concat from_dir f else 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 let rec aux acc rbase = function
| [] -> acc | [] -> acc
| dir :: p -> | dir :: p -> (
if dir = Filename.parent_dir_name then match rbase with if dir = Filename.parent_dir_name then
match rbase with
| base1 :: rbase -> aux (base1 :: acc) rbase p | base1 :: rbase -> aux (base1 :: acc) rbase p
| [] -> aux acc [] p | [] -> aux acc [] p
else else
match acc with match acc with
| dir1 :: acc when dir1 = dir -> aux acc rbase p | 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 in
let path_to_list path = let path_to_list path =
String.split_on_char Filename.dir_sep.[0] path String.split_on_char Filename.dir_sep.[0] path
|> List.filter (function "" | "." -> false | _ -> true) |> List.filter (function "" | "." -> false | _ -> true)
in in
let rbase = List.rev (path_to_list (from_dir)) 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)) String.concat Filename.dir_sep
(aux (path_to_list f) rbase (path_to_list to_dir))
(** CLI flags and options *) (** CLI flags and options *)
@ -156,8 +155,8 @@ module Flags = struct
let converter = let converter =
conv ~docv:"FILE" conv ~docv:"FILE"
( (fun s -> ( (fun s ->
if s = "-" then Ok (Stdin "-stdin-") else if s = "-" then Ok (Stdin "-stdin-")
Result.map (fun f -> FileName f) (conv_parser non_dir_file s)), else Result.map (fun f -> FileName f) (conv_parser non_dir_file s)),
fun ppf -> function fun ppf -> function
| Stdin _ -> Format.pp_print_string ppf "-" | Stdin _ -> Format.pp_print_string ppf "-"
| FileName f -> conv_printer non_dir_file ppf f | FileName f -> conv_printer non_dir_file ppf f
@ -262,13 +261,17 @@ module Flags = struct
value value
& opt (some string) None & opt (some string) None
& info ["name"] ~docv:"FILE" & 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 = let directory =
value value
& opt (some dir) None & opt (some dir) None
& info ["C"; "directory"] ~docv:"DIR" & 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 flags =
let make let make
@ -280,14 +283,13 @@ module Flags = struct
plugins_dirs plugins_dirs
disable_warnings disable_warnings
max_prec_digits max_prec_digits
directory: options = directory : options =
if debug then Printexc.record_backtrace true; if debug then Printexc.record_backtrace true;
let path_rewrite = let path_rewrite =
match directory with match directory with
| None -> fun f -> f | None -> fun f -> f
| Some to_dir -> function | Some to_dir -> (
| "-" -> "-" function "-" -> "-" | f -> reverse_path ~to_dir f)
| f -> reverse_path ~to_dir f
in in
(* This sets some global refs for convenience, but most importantly (* This sets some global refs for convenience, but most importantly
returns the options record. *) returns the options record. *)
@ -312,16 +314,16 @@ module Flags = struct
let input_src = let input_src =
match name with match name with
| None -> input_src | None -> input_src
| Some name -> | Some name -> (
match input_src with match input_src with
| FileName f -> FileName f | FileName f -> FileName f
| Contents (str, _) -> Contents (str, name) | Contents (str, _) -> Contents (str, name)
| Stdin _ -> Stdin name | Stdin _ -> Stdin name)
in in
let input_src = let input_src =
match input_src with match input_src with
| FileName f -> FileName (options.path_rewrite f) | 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) | Stdin f -> Stdin (options.path_rewrite f)
in in
let plugins_dirs = List.map options.path_rewrite options.plugins_dirs in let plugins_dirs = List.map options.path_rewrite options.plugins_dirs in
@ -336,9 +338,8 @@ module Flags = struct
let include_dirs = let include_dirs =
value value
& opt_all string [] & opt_all string []
& info ["I";"include"] ~docv:"DIR" & info ["I"; "include"] ~docv:"DIR"
~doc: ~doc:"Include directory to lookup for compiled module files."
"Include directory to lookup for compiled module files."
let check_invariants = let check_invariants =
value value
@ -378,11 +379,11 @@ module Flags = struct
value value
& opt (some string) None & opt (some string) None
& info ["output"; "o"] ~docv:"OUTPUT" & info ["output"; "o"] ~docv:"OUTPUT"
~env:(Cmd.Env.info "CATALA_OUT") ~env:(Cmd.Env.info "CATALA_OUT")
~doc: ~doc:
"$(i, OUTPUT) is the file that will contain the output of the \ "$(i, OUTPUT) is the file that will contain the output of the \
compiler. Defaults to $(i,FILE).$(i,EXT) where $(i,EXT) depends on \ compiler. Defaults to $(i,FILE).$(i,EXT) where $(i,EXT) depends on \
the chosen backend. Use $(b,-o -) for stdout." the chosen backend. Use $(b,-o -) for stdout."
let optimize = let optimize =
value & flag & info ["optimize"; "O"] ~doc:"Run compiler optimizations." 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 \ "Disables the search for counterexamples. Useful when you want a \
deterministic output from the Catala compiler, since provers can \ deterministic output from the Catala compiler, since provers can \
have some randomness in them." have some randomness in them."
end end
(* Retrieve current version from dune *) (* 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 *) (** File names ; equal to [File.t] but let's avoid cyclic dependencies *)
type raw_file 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 type backend_lang = En | Fr | Pl
@ -34,18 +35,22 @@ type message_format_enum =
(** Sources for program input *) (** Sources for program input *)
type input_src = type input_src =
| FileName of file (** A file path to read from disk *) | 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 *) | Contents of string * file
| Stdin of file (** Read from stdin; the specified filename will be used for file lookups, error reportings, etc. *) (** 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 languages : (string * backend_lang) list
val language_code : backend_lang -> string val language_code : backend_lang -> string
(** Returns the lowercase two-letter language code *) (** Returns the lowercase two-letter language code *)
val file_lang : file -> backend_lang
(** Associates a file extension with its corresponding {!type: Cli.backend_lang} (** Associates a file extension with its corresponding {!type: Cli.backend_lang}
string representation. *) string representation. *)
val file_lang : file -> backend_lang
val input_src_file : input_src -> file 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 with Unix.Unix_error _ | Sys_error _ -> None
let ( / ) a b = let ( / ) a b =
if a = "" || a = Filename.current_dir_name then b if a = "" || a = Filename.current_dir_name then b else Filename.concat a b
else Filename.concat a b
let dirname = Filename.dirname let dirname = Filename.dirname
let ( /../ ) a b = dirname a / b let ( /../ ) a b = dirname a / b
let ( -.- ) file ext = Filename.chop_extension file ^ "." ^ ext let ( -.- ) file ext = Filename.chop_extension file ^ "." ^ ext
@ -183,24 +183,24 @@ module Tree = struct
let empty = lazy Map.empty let empty = lazy Map.empty
let rec build path = lazy let rec build path =
(Array.fold_left lazy
(fun m f -> (Array.fold_left
let path = path / f in (fun m f ->
match Sys.is_directory path with let path = path / f in
| true -> Map.add f (path, D (build path)) m match Sys.is_directory path with
| false -> Map.add f (path, F) m | true -> Map.add f (path, D (build path)) m
| exception Sys_error _ -> m) | false -> Map.add f (path, F) m
Map.empty | exception Sys_error _ -> m)
(Sys.readdir path)) Map.empty (Sys.readdir path))
let subtree t path = let subtree t path =
let rec aux t = function let rec aux t = function
| [] -> t | [] -> t
| dir :: path -> | dir :: path -> (
match Map.find_opt dir (Lazy.force t) with match Map.find_opt dir (Lazy.force t) with
| Some (_, D sub) -> aux sub path | Some (_, D sub) -> aux sub path
| Some (_, F) | None -> raise Not_found | Some (_, F) | None -> raise Not_found)
in in
aux t (path_to_list path) aux t (path_to_list path)
@ -212,6 +212,6 @@ module Tree = struct
| Some (_, D _) | None -> None | Some (_, D _) | None -> None
with Not_found -> 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 end

39
compiler/catala_utils/file.mli
View File

@ -86,11 +86,13 @@ val check_directory : t -> t option
[Unix.realpath]). *) [Unix.realpath]). *)
val check_file : t -> t option 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 val ( / ) : t -> t -> t
(** [Filename.concat]: Sugar to allow writing (** [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 val dirname : t -> t
(** [Filename.dirname], re-exported for convenience *) (** [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 or "_*" are ignored. Unreadable files or subdirectories are ignored with a
debug message. If [t] is a plain file, scan just that non-recursively. *) debug message. If [t] is a plain file, scan just that non-recursively. *)
module Tree: sig module Tree : sig
(** A lazy tree structure mirroring the filesystem ; uses the comparison from File, so paths are case-insensitive. *) (** 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 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 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/"]) *) (** 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 *) (** Looks up a path within a lazy tree *)
val lookup: t -> path -> path option 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 *) (** 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 *) (** Merges two trees. In case of conflict, lhs entry wins *)
end end

4
compiler/catala_utils/pos.ml
View File

@ -146,14 +146,14 @@ let format_loc_text ppf (pos : t) =
| None -> None | None -> None
in in
None, input_line_opt None, input_line_opt
| None -> | None -> (
try try
let ic = open_in filename in let ic = open_in filename in
let input_line_opt () : string option = let input_line_opt () : string option =
try Some (input_line ic) with End_of_file -> None try Some (input_line ic) with End_of_file -> None
in in
Some ic, input_line_opt Some ic, input_line_opt
with Sys_error _ -> None, (fun () -> None) with Sys_error _ -> None, fun () -> None)
in in
let include_extra_count = 0 in let include_extra_count = 0 in
let rec get_lines (n : int) : (int * string) list = 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 Message.raise_error "Unrecognised input locale %S" language
in in
let options = 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 () ~language:(Some language) ~debug:false ~color:Never ~trace ()
in in
let prg, ctx, _type_order = 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.CodeBlock (block, _, _) -> process_code_block ctxt prgm block
| S.ModuleDef ((name, pos) as mname) -> | S.ModuleDef ((name, pos) as mname) ->
let file = Filename.basename (Pos.get_file pos) in let file = Filename.basename (Pos.get_file pos) in
if not File.(equal name (Filename.remove_extension file)) if not File.(equal name (Filename.remove_extension file)) then
then
Message.raise_spanned_error pos Message.raise_spanned_error pos
"Module declared as %a, which does not match the file name %a" "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 File.format file
else prgm else prgm
| S.LawInclude _ | S.LawText _ | S.ModuleUse _ -> 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)) String.capitalize_ascii Filename.(basename (remove_extension f))
let load_module_interfaces options includes program = 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 = let includes =
includes includes
|> List.map (fun d -> File.Tree.build (options.Cli.path_rewrite d)) |> List.map (fun d -> File.Tree.build (options.Cli.path_rewrite d))
@ -45,21 +46,18 @@ let load_module_interfaces options includes program =
in in
match match
List.filter_map List.filter_map
(fun (ext, _) -> (fun (ext, _) -> File.Tree.lookup includes (fname_base ^ ext))
File.Tree.lookup includes (fname_base ^ ext))
extensions extensions
with with
| [] -> | [] ->
Message.raise_multispanned_error (err_req_pos (m::req_chain)) Message.raise_multispanned_error
"Required module not found: %a" (err_req_pos (m :: req_chain))
ModuleName.format m "Required module not found: %a" ModuleName.format m
| [f] -> | [f] -> f
f
| ms -> | ms ->
Message.raise_multispanned_error Message.raise_multispanned_error
(err_req_pos (m::req_chain)) (err_req_pos (m :: req_chain))
"Required module %a matches multiple files: %a" "Required module %a matches multiple files: %a" ModuleName.format m
ModuleName.format m
(Format.pp_print_list ~pp_sep:Format.pp_print_space File.format) (Format.pp_print_list ~pp_sep:Format.pp_print_space File.format)
ms ms
in in
@ -70,27 +68,27 @@ let load_module_interfaces options includes program =
(ModuleName.of_string mname, intf), using (ModuleName.of_string mname, intf), using
in in
let rec aux req_chain acc modules = 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 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 f = find_module req_chain m in
let (m', intf), using = load_file f in let (m', intf), using = load_file f in
if not (ModuleName.equal m m') then if not (ModuleName.equal m m') then
Message.raise_multispanned_error Message.raise_multispanned_error
((Some "Module name declaration", ModuleName.pos m') :: ((Some "Module name declaration", ModuleName.pos m')
err_req_pos (m::req_chain)) :: err_req_pos (m :: req_chain))
"Mismatching module name declaration:"; "Mismatching module name declaration:";
let acc = (m', intf) :: acc in let acc = (m', intf) :: acc in
aux (m::req_chain) acc using aux (m :: req_chain) acc using)
)
acc modules acc modules
in in
let program_modules = let program_modules =
aux [] [] (List.map fst program.Surface.Ast.program_modules) aux [] [] (List.map fst program.Surface.Ast.program_modules)
|> List.map (fun (m, i) -> (m : ModuleName.t :> string Mark.pos), i) |> List.map (fun (m, i) -> (m : ModuleName.t :> string Mark.pos), i)
in in
{ program with { program with Surface.Ast.program_modules }
Surface.Ast.program_modules }
module Passes = struct module Passes = struct
(* Each pass takes only its cli options, then calls upon its dependent passes (* 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 get_output ?ext options output_file =
let output_file = Option.map options.Cli.path_rewrite output_file in 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 get_output_format ?ext options output_file =
let output_file = Option.map options.Cli.path_rewrite output_file in 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.avoid_exceptions
$ Cli.Flags.closure_conversion) $ 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 = let prg, _, type_ordering =
Passes.scalc options ~includes ~optimize ~check_invariants Passes.scalc options ~includes ~optimize ~check_invariants
~avoid_exceptions:false ~closure_conversion ~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 Each pass takes only its cli options, then calls upon its dependent passes
(forwarding their options as needed) *) (forwarding their options as needed) *)
module Passes : sig module Passes : sig
val surface : val surface : Cli.options -> includes:Cli.raw_file list -> Surface.Ast.program
Cli.options ->
includes:Cli.raw_file list ->
Surface.Ast.program
val desugared : val desugared :
Cli.options -> Cli.options ->

2
compiler/plugin.ml
View File

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

5
compiler/plugins/explain.ml
View File

@ -1416,7 +1416,10 @@ let run includes optimize ex_scope explain_options global_options =
| { output; _ } -> | { output; _ } ->
let _, with_out = Driver.Commands.get_output global_options output in let _, with_out = Driver.Commands.get_output global_options output in
with_out (fun oc -> output_string oc dot_content); 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 in
with_dot_file with_dot_file
@@ fun dotfile -> @@ 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_runtime_modules prg =
let load m = let load m =
let obj_file = 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 in
if not (Sys.file_exists obj_file) then if not (Sys.file_exists obj_file) then
Message.raise_spanned_error Message.raise_spanned_error
~span_msg:(fun ppf -> Format.pp_print_string ppf "Module defined here") ~span_msg:(fun ppf -> Format.pp_print_string ppf "Module defined here")
(ModuleName.pos m) (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 else
try Dynlink.loadfile obj_file try Dynlink.loadfile obj_file
with Dynlink.Error dl_err -> with Dynlink.Error dl_err ->
Message.raise_error Message.raise_error
"Error loading compiled module from %a:@;\ "Error loading compiled module from %a:@;<1 2>@[<hov>%a@]" File.format
<1 2>@[<hov>%a@]" File.format obj_file obj_file Format.pp_print_text
Format.pp_print_text
(Dynlink.error_message dl_err) (Dynlink.error_message dl_err)
in in
let rec aux loaded decl_ctx = let rec aux loaded decl_ctx =
ModuleName.Map.fold (fun mname sub_decl_ctx loaded -> ModuleName.Map.fold
if ModuleName.Set.mem mname loaded then loaded else (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 = ModuleName.Set.add mname loaded in
let loaded = aux loaded sub_decl_ctx in let loaded = aux loaded sub_decl_ctx in
load mname; load mname;
@ -972,5 +977,5 @@ let load_runtime_modules prg =
Message.emit_debug "Loading shared modules... %a" Message.emit_debug "Loading shared modules... %a"
(fun ppf -> ModuleName.Map.format_keys ppf) (fun ppf -> ModuleName.Map.format_keys ppf)
prg.decl_ctx.ctx_modules; 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) Fun.protect ~finally:(fun () -> close_in ic) (fun () -> f lexbuf)
(** Parses a single source file *) (** Parses a single source file *)
let rec parse_source let rec parse_source (lexbuf : Sedlexing.lexbuf) : Ast.program =
(lexbuf: Sedlexing.lexbuf)
: Ast.program =
let source_file_name = lexbuf_file lexbuf in let source_file_name = lexbuf_file lexbuf in
Message.emit_debug "Parsing %a" File.format source_file_name; Message.emit_debug "Parsing %a" File.format source_file_name;
let language = Cli.file_lang source_file_name in 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 (** Expands the include directives in a parsing result, thus parsing new source
files *) files *)
and expand_includes and expand_includes (source_file : string) (commands : Ast.law_structure list) :
(source_file : string) Ast.program =
(commands : Ast.law_structure list) : Ast.program =
let language = Cli.file_lang source_file in let language = Cli.file_lang source_file in
let rprg = let rprg =
List.fold_left List.fold_left
@ -270,8 +267,10 @@ and expand_includes
| Ast.ModuleDef id -> ( | Ast.ModuleDef id -> (
match acc.Ast.program_module_name with match acc.Ast.program_module_name with
| None -> | 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 -> | Some id2 ->
Message.raise_multispanned_error Message.raise_multispanned_error
@ -286,7 +285,8 @@ and expand_includes
| Ast.LawInclude (Ast.CatalaFile inc_file) -> | Ast.LawInclude (Ast.CatalaFile inc_file) ->
let source_dir = Filename.dirname source_file in let source_dir = Filename.dirname source_file in
let sub_source = File.(source_dir / Mark.remove inc_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 = parse_source lexbuf in
let () = let () =
includ_program.Ast.program_module_name includ_program.Ast.program_module_name
@ -390,9 +390,7 @@ let with_sedlex_source source_file f =
f lexbuf f lexbuf
let load_interface source_file = let load_interface source_file =
let program = let program = with_sedlex_source source_file parse_source in
with_sedlex_source source_file parse_source
in
let modname = let modname =
match program.Ast.program_module_name with match program.Ast.program_module_name with
| Some mname -> mname | Some mname -> mname
@ -410,11 +408,8 @@ let load_interface source_file =
let used_modules, intf = get_interface program in let used_modules, intf = get_interface program in
(modname, intf), used_modules (modname, intf), used_modules
let parse_top_level_file let parse_top_level_file (source_file : Cli.input_src) : Ast.program =
(source_file : Cli.input_src) let program = with_sedlex_source source_file parse_source in
: Ast.program =
let program =
with_sedlex_source source_file parse_source in
{ {
program with program with
Ast.program_items = law_struct_list_to_tree program.Ast.program_items; 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 (** Raw file parser that doesn't interpret any includes and returns the flat law
structure as is *) structure as is *)
val load_interface : val load_interface : Cli.input_src -> Ast.interface * string Mark.pos list
Cli.input_src -> Ast.interface * string Mark.pos list
(** Reads only declarations in metadata in the supplied input file, and only (** Reads only declarations in metadata in the supplied input file, and only
keeps type information ; returns the modules used as well *) keeps type information ; returns the modules used as well *)