From a79acd1fa8b701a5688c7fa985c7064cd6d81acf Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Wed, 27 Sep 2023 13:06:30 +0200 Subject: [PATCH] Reformat --- build_system/clerk_driver.ml | 229 +++++++++++++---------------- build_system/clerk_driver.mli | 4 +- build_system/clerk_runtest.ml | 45 +++--- build_system/clerk_scan.ml | 24 ++- build_system/clerk_scan.mli | 18 ++- compiler/catala_utils/cli.ml | 78 +++++----- compiler/catala_utils/cli.mli | 15 +- compiler/catala_utils/file.ml | 32 ++-- compiler/catala_utils/file.mli | 39 +++-- compiler/catala_utils/pos.ml | 4 +- compiler/catala_web_interpreter.ml | 3 +- compiler/desugared/from_surface.ml | 6 +- compiler/driver.ml | 42 +++--- compiler/driver.mli | 5 +- compiler/plugin.ml | 2 +- compiler/plugins/explain.ml | 5 +- compiler/shared_ast/interpreter.ml | 21 ++- compiler/surface/parser_driver.ml | 29 ++-- compiler/surface/parser_driver.mli | 3 +- 19 files changed, 300 insertions(+), 304 deletions(-) diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index d8e79760..ffd5a37b 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -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,/clerk.ninja) in debug mode, and a temporary file otherwise") + output. If not specified, the build.ninja file is set to \ + $(i,/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 @{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 @{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:[""; !input ]; - + ~command:["cp"; "-f"; !input; !output] + ~description:[""; !input]; Nj.rule "catala-ocaml" - ~command: - [ - !catala_exe; - "ocaml"; - !catala_flags; - !input; - "-o"; - !output; - ] + ~command:[!catala_exe; "ocaml"; !catala_flags; !input; "-o"; !output] ~description:[""; "ocaml"; "⇒"; !output]; Nj.rule "ocaml-module" ~command: - [ - !ocamlopt_exe; - "-shared"; - !ocamlopt_flags; - !input; - "-o"; - !output; - ] + [!ocamlopt_exe; "-shared"; !ocamlopt_flags; !input; "-o"; !output] ~description:[""; "⇒"; !output]; Nj.rule "ocaml-exec" ~command: @@ -455,28 +445,13 @@ let static_base_rules = [""; "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:[""; "inline-tests"; "⇐"; !input]; - Nj.rule "post-test" - ~command: - [!post_test; !input] + Nj.rule "post-test" ~command:[!post_test; !input] ~description:[""]; Nj.rule "interpret" ~command: - [ - !catala_exe; - "interpret"; - !catala_flags; - !input; - "--scope=" ^ !scope; - ] + [!catala_exe; "interpret"; !catala_flags; !input; "--scope=" ^ !scope] ~description:[""; "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 = diff --git a/build_system/clerk_driver.mli b/build_system/clerk_driver.mli index 10a34c8a..783d0375 100644 --- a/build_system/clerk_driver.mli +++ b/build_system/clerk_driver.mli @@ -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 diff --git a/build_system/clerk_runtest.ml b/build_system/clerk_runtest.ml index 20ba687b..f387f249 100644 --- a/build_system/clerk_runtest.ml +++ b/build_system/clerk_runtest.ml @@ -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 '\n" + output_string oc + "[INVALID TEST] Missing test command, use '$ catala '\n" | Some ((str, L.LINE_BLOCK_END), lines) -> - output_string oc "[INVALID TEST] Missing test command, use '$ catala '\n"; + output_string oc + "[INVALID TEST] Missing test command, use '$ catala '\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 '\n"; + output_string oc + "[INVALID TEST] Invalid test command syntax, must match '$ catala \ + '\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 diff --git a/build_system/clerk_scan.ml b/build_system/clerk_scan.ml index 33d864c2..0e2bb8e4 100644 --- a/build_system/clerk_scan.ml +++ b/build_system/clerk_scan.ml @@ -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 diff --git a/build_system/clerk_scan.mli b/build_system/clerk_scan.mli index 0f54fa85..e069f47e 100644 --- a/build_system/clerk_scan.mli +++ b/build_system/clerk_scan.mli @@ -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 ") 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 ") and returns the + arguments as a string, or [None] if there is no match *) diff --git a/compiler/catala_utils/cli.ml b/compiler/catala_utils/cli.ml index e69d9a70..2a53edc2 100644 --- a/compiler/catala_utils/cli.ml +++ b/compiler/catala_utils/cli.ml @@ -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 = @{%s@}, and @{--language@} was not specified" filename) -(** If [to_dir] is a path to a given directory and [f] a path to a file as seen from absolute path [from_dir], [reverse_path ~from_dir ~to_dir f] is a path leading to [f] from [to_dir]. The results attempts to be relative to [to_dir]. *) -let reverse_path ?(from_dir=Sys.getcwd()) ~to_dir f = - if Filename.is_relative from_dir then invalid_arg "File.with_reverse_path" else - if not (Filename.is_relative f) then f else - if not (Filename.is_relative to_dir) then Filename.concat from_dir f else +(** 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 *) diff --git a/compiler/catala_utils/cli.mli b/compiler/catala_utils/cli.mli index e9b116a9..42b58f78 100644 --- a/compiler/catala_utils/cli.mli +++ b/compiler/catala_utils/cli.mli @@ -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 diff --git a/compiler/catala_utils/file.ml b/compiler/catala_utils/file.ml index a87216ea..c5c859e8 100644 --- a/compiler/catala_utils/file.ml +++ b/compiler/catala_utils/file.ml @@ -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 diff --git a/compiler/catala_utils/file.mli b/compiler/catala_utils/file.mli index bc314d6d..a997b331 100644 --- a/compiler/catala_utils/file.mli +++ b/compiler/catala_utils/file.mli @@ -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 diff --git a/compiler/catala_utils/pos.ml b/compiler/catala_utils/pos.ml index 093e2e2c..4f5df1fe 100644 --- a/compiler/catala_utils/pos.ml +++ b/compiler/catala_utils/pos.ml @@ -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 = diff --git a/compiler/catala_web_interpreter.ml b/compiler/catala_web_interpreter.ml index b40022d9..604db2f9 100644 --- a/compiler/catala_web_interpreter.ml +++ b/compiler/catala_web_interpreter.ml @@ -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 = diff --git a/compiler/desugared/from_surface.ml b/compiler/desugared/from_surface.ml index 2b57d2b5..a9bb6907 100644 --- a/compiler/desugared/from_surface.ml +++ b/compiler/desugared/from_surface.ml @@ -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 diff --git a/compiler/driver.ml b/compiler/driver.ml index a32a8ce3..187b4006 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -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 diff --git a/compiler/driver.mli b/compiler/driver.mli index f37f7013..2eea7d6d 100644 --- a/compiler/driver.mli +++ b/compiler/driver.mli @@ -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 -> diff --git a/compiler/plugin.ml b/compiler/plugin.ml index 56e9acfb..d6b0736f 100644 --- a/compiler/plugin.ml +++ b/compiler/plugin.ml @@ -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 diff --git a/compiler/plugins/explain.ml b/compiler/plugins/explain.ml index f615e0a0..a801e181 100644 --- a/compiler/plugins/explain.ml +++ b/compiler/plugins/explain.ml @@ -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 -> diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index e7c5a7aa..4e1a516b 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -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>@[%a@]" File.format obj_file - Format.pp_print_text + "Error loading compiled module from %a:@;<1 2>@[%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 () diff --git a/compiler/surface/parser_driver.ml b/compiler/surface/parser_driver.ml index a10b4008..533e0e94 100644 --- a/compiler/surface/parser_driver.ml +++ b/compiler/surface/parser_driver.ml @@ -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; diff --git a/compiler/surface/parser_driver.mli b/compiler/surface/parser_driver.mli index 923281db..9b19ae9e 100644 --- a/compiler/surface/parser_driver.mli +++ b/compiler/surface/parser_driver.mli @@ -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 *)