From 4bce4e6322ede5cddb7384511f2fc0d05416f97f Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Tue, 19 Sep 2023 18:21:14 +0200 Subject: [PATCH] Reformat --- build_system/clerk_driver.ml | 884 ++++++++++++++++---------- build_system/clerk_runtest.ml | 13 +- build_system/ninja_utils.ml | 92 ++- build_system/ninja_utils.mli | 56 +- compiler/catala_utils/cli.ml | 7 +- compiler/catala_utils/cli.mli | 2 +- compiler/catala_utils/dune | 10 +- compiler/catala_utils/file.ml | 12 +- compiler/catala_utils/file.mli | 5 +- compiler/catala_utils/uid.ml | 5 +- compiler/catala_utils/uid.mli | 2 +- compiler/desugared/from_surface.ml | 14 +- compiler/desugared/linting.ml | 236 +++---- compiler/desugared/name_resolution.ml | 4 +- compiler/driver.ml | 53 +- compiler/lcalc/closure_conversion.ml | 7 +- compiler/lcalc/to_ocaml.ml | 8 +- compiler/plugins/modules.ml | 7 +- compiler/shared_ast/interpreter.ml | 31 +- compiler/shared_ast/interpreter.mli | 6 +- compiler/surface/ast.ml | 3 +- compiler/surface/lexer_common.mli | 4 +- compiler/surface/parser_driver.ml | 164 ++--- compiler/surface/parser_driver.mli | 10 +- 24 files changed, 954 insertions(+), 681 deletions(-) diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index 31d93318..8c2ceb52 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -20,48 +20,54 @@ open Ninja_utils module Nj = Ninja_utils (* Version is synchronised with the catala version *) -let version = - Catala_utils.Cli.version +let version = Catala_utils.Cli.version (** {1 Command line interface} *) module Cli = struct - open Cmdliner let catala_exe = Arg.( value & opt (some string) None - & info ["e"; "exe"] ~docv:"EXE" - ~doc:"Catala compiler executable.") + & info ["e"; "exe"] ~docv:"EXE" ~doc:"Catala compiler executable.") let catala_opts = Arg.( value & opt_all string [] & info ["c"; "catala-opts"] ~docv:"FLAG" - ~doc:"Option to pass to the Catala compiler. Can be repeated.") + ~doc:"Option to pass to the Catala compiler. Can be repeated.") - module Global: sig - val term: - (chdir:File.t option -> catala_exe:File.t option -> catala_opts:string list -> color:Cli.when_enum -> debug:bool -> ninja_output:File.t option -> 'a) -> 'a Term.t + module Global : sig + val term : + (chdir:File.t option -> + catala_exe:File.t option -> + catala_opts:string list -> + color:Cli.when_enum -> + debug:bool -> + ninja_output:File.t option -> + 'a) -> + 'a Term.t end = struct - let chdir = - Arg.(value & opt (some string) None - & info ["C"] ~docv:"DIR" - ~doc:"Change to the given directory before processing") + Arg.( + value + & opt (some string) None + & info ["C"] ~docv:"DIR" + ~doc:"Change to the given directory before processing") let color = - Arg.(value - & opt ~vopt:Cli.Always Cli.when_opt Auto - & info ["color"] - ~env:(Cmd.Env.info "CATALA_COLOR") - ~doc: - "Allow output of colored and styled text. Use $(i,auto), to \ - enable when the standard output is to a terminal, $(i,never) to \ - disable.") + Arg.( + value + & opt ~vopt:Cli.Always Cli.when_opt Auto + & info ["color"] + ~env:(Cmd.Env.info "CATALA_COLOR") + ~doc: + "Allow output of colored and styled text. Use $(i,auto), to \ + enable when the standard output is to a terminal, $(i,never) to \ + disable.") let debug = Arg.(value & flag & info ["debug"; "d"] ~doc:"Prints debug information") @@ -71,17 +77,22 @@ module Cli = struct value & opt (some string) None & 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 will be output in \ - the temporary directory of the system and cleaned up on exit.") + ~doc: + "$(i,FILE) is the file that will contain the build.ninja file \ + output. If not specified, the build.ninja file will be output \ + in the temporary directory of the system and cleaned up on \ + exit.") let term f = - Term.(const - (fun chdir catala_exe catala_opts color debug ninja_output -> - f ~chdir ~catala_exe ~catala_opts ~color ~debug ~ninja_output) - $ chdir $ catala_exe $ catala_opts $ color $ debug $ ninja_output) - + Term.( + const (fun chdir catala_exe catala_opts color debug ninja_output -> + f ~chdir ~catala_exe ~catala_opts ~color ~debug ~ninja_output) + $ chdir + $ catala_exe + $ catala_opts + $ color + $ debug + $ ninja_output) end let files_or_folders = @@ -101,29 +112,34 @@ module Cli = struct value & flag & info ["r"; "reset"] - ~doc: - "Used with the `test` command, resets the test output to whatever is \ - output by the Catala compiler.") + ~doc: + "Used with the `test` command, resets the test output to whatever \ + is output by the Catala compiler.") let scope = Arg.( required & opt (some string) None & info ["s"; "scope"] ~docv:"SCOPE" - ~doc: - "Used with the `run` command, selects which scope of a given Catala \ - file to run.") + ~doc: + "Used with the `run` command, selects which scope of a given \ + Catala file to run.") let targets = Arg.( value & pos_all string [] & info [] ~docv:"TARGETS" - ~doc:"Flags or targets to forward to Ninja directly (use $(b,-- ninja_flags) to separate Ninja flags from Clerk flags)") + ~doc: + "Flags or targets to forward to Ninja directly (use $(b,-- \ + ninja_flags) to separate Ninja flags from Clerk flags)") let ninja_flags = let env = - Cmd.Env.info ~doc:("make-compatible flags handling. Currently recognizes the -i and -j options and forwards them through to Ninja.") + Cmd.Env.info + ~doc: + "make-compatible flags handling. Currently recognizes the -i and -j \ + options and forwards them through to Ninja." "MAKEFLAGS" in let makeflags = @@ -131,9 +147,9 @@ module Cli = struct value & opt (some string) None & info ["makeflags"] ~env ~docv:"FLAG" - ~doc: - "Provides the contents of a $(i, MAKEFLAGS) variable to pass on to \ - Ninja. Currently recognizes the -i and -j options.") + ~doc: + "Provides the contents of a $(i, MAKEFLAGS) variable to pass on \ + to Ninja. Currently recognizes the -i and -j options.") in let makeflags_to_ninja_flags (makeflags : string option) = match makeflags with @@ -143,7 +159,8 @@ module Cli = struct let has_ignore = Re.execp ignore_rex makeflags in let jobs_rex = Re.(compile @@ seq [str "-j"; group (rep digit)]) in let number_of_jobs = - try ["-j" ^ Re.Group.get (Re.exec jobs_rex makeflags) 1] with _ -> [] + try ["-j" ^ Re.Group.get (Re.exec jobs_rex makeflags) 1] + with _ -> [] in String.concat " " ((if has_ignore then ["-k0"] else []) @ number_of_jobs) in @@ -158,8 +175,8 @@ module Cli = struct [ `S Manpage.s_description; `P - "$(b,clerk) is a build system for Catala, a specification language for \ - tax and social benefits computation rules"; + "$(b,clerk) is a build system for Catala, a specification language \ + for tax and social benefits computation rules"; `S Manpage.s_authors; `P "Denis Merigoux "; `P "Emile Rolley "; @@ -169,7 +186,8 @@ module Cli = struct `Pre "clerk test file.catala_en"; `S Manpage.s_bugs; `P - "Please file bug reports at https://github.com/CatalaLang/catala/issues"; + "Please file bug reports at \ + https://github.com/CatalaLang/catala/issues"; ] in let exits = Cmd.Exit.defaults @ [Cmd.Exit.info ~doc:"on error." 1] in @@ -200,15 +218,25 @@ type catala_build_item = { legacy_tests : expected_output_descr list; has_inline_tests : bool; } -(** Contains all the data extracted from a single Catala file. Lists are in reverse file order. *) +(** Contains all the data extracted from a single Catala file. Lists are in + reverse file order. *) let catala_suffix_regex = Re.(compile (seq [str ".catala_"; group (seq [alpha; alpha]); eos])) let test_command_re = let open Re in - compile @@ - seq [bos; char '$'; rep space; str "catala"; rep space; group (rep1 notnl); char '\n'] + compile + @@ seq + [ + bos; + char '$'; + rep space; + str "catala"; + rep space; + group (rep1 notnl); + char '\n'; + ] let scan_catala_file (file : File.t) (lang : Catala_utils.Cli.backend_lang) : catala_build_item = @@ -217,52 +245,55 @@ let scan_catala_file (file : File.t) (lang : Catala_utils.Cli.backend_lang) : match Seq.uncons lines with | None -> acc | Some ((_, L.LINE_TEST id), lines) -> - let test, lines, n = parse_test id lines (n+1) in + let test, lines, n = parse_test id lines (n + 1) in parse lines n { acc with legacy_tests = test :: acc.legacy_tests } - | Some ((_, line), lines) -> - parse lines (n+1) @@ + | Some ((_, line), lines) -> ( + parse lines (n + 1) + @@ match line with | L.LINE_INCLUDE f -> let f = if Filename.is_relative f then File.(file /../ f) else f in { acc with included_files = f :: acc.included_files } - | L.LINE_MODULE_DEF m -> - { acc with module_def = Some m } - | L.LINE_MODULE_USE m -> - { acc with used_modules = m :: acc.used_modules } - | L.LINE_INLINE_TEST -> - { acc with has_inline_tests = true } - | _ -> acc + | L.LINE_MODULE_DEF m -> { acc with module_def = Some m } + | L.LINE_MODULE_USE m -> { acc with used_modules = m :: acc.used_modules } + | L.LINE_INLINE_TEST -> { acc with has_inline_tests = true } + | _ -> acc) and parse_test id lines n = let test = - { id; + { + id; tested_filename = file; output_dir = File.(file /../ "output" / ""); - cmd = [] } + cmd = []; + } in let err n = [Format.asprintf "'invalid test syntax at %a:%d'" File.format file n] in match Seq.uncons lines with - | Some ((str, L.LINE_ANY), lines) -> - (match Re.exec_opt test_command_re str with - | Some args_grp -> - let cmd = String.trim (Re.Group.get args_grp 1) in - let cmd, lines, n = parse_block lines (n+1) [cmd] in - { test with cmd = List.flatten (List.map (String.split_on_char ' ') cmd) }, - lines, (n+1) - | None -> { test with cmd = err n}, lines, n+1) - | Some (_, lines) -> - { test with cmd = err n}, lines, n+1 - | None -> - { test with cmd = err n}, lines, n + | Some ((str, L.LINE_ANY), lines) -> ( + match Re.exec_opt test_command_re str with + | Some args_grp -> + let cmd = String.trim (Re.Group.get args_grp 1) in + let cmd, lines, n = parse_block lines (n + 1) [cmd] in + ( { + test with + cmd = List.flatten (List.map (String.split_on_char ' ') cmd); + }, + lines, + n + 1 ) + | None -> { test with cmd = err n }, lines, n + 1) + | Some (_, lines) -> { test with cmd = err n }, lines, n + 1 + | None -> { test with cmd = err n }, lines, n and parse_block lines n acc = match Seq.uncons lines with - | Some ((_, L.LINE_BLOCK_END), lines) -> List.rev acc, lines, n+1 - | Some ((str, _), lines) -> String.trim str :: acc, lines, n+1 + | Some ((_, L.LINE_BLOCK_END), lines) -> List.rev acc, lines, n + 1 + | Some ((str, _), lines) -> String.trim str :: acc, lines, n + 1 | None -> List.rev acc, lines, n in parse - (Surface.Parser_driver.lines file lang) 1 + (Surface.Parser_driver.lines file lang) + 1 { file_name = file; module_def = None; @@ -273,8 +304,8 @@ let scan_catala_file (file : File.t) (lang : Catala_utils.Cli.backend_lang) : } let get_lang file = - Option.bind (Re.exec_opt catala_suffix_regex file) @@ fun g -> - List.assoc_opt (Re.Group.get g 1) Catala_utils.Cli.languages + Option.bind (Re.exec_opt catala_suffix_regex file) + @@ fun g -> List.assoc_opt (Re.Group.get g 1) Catala_utils.Cli.languages let scan_tree (dir : File.t) : catala_build_item Seq.t = File.scan_tree @@ -288,9 +319,8 @@ let scan_tree (dir : File.t) : catala_build_item Seq.t = (** Some functions that poll the surrounding systems (think [./configure]) *) module Poll = struct - (** Scans for a parent directory being the root of the Catala source repo *) - let catala_project_root: File.t option Lazy.t = + let catala_project_root : File.t option Lazy.t = let rec aux dir = if Sys.file_exists File.(dir / "catala.opam") then Some dir else @@ -299,43 +329,46 @@ module Poll = struct in lazy (aux (Sys.getcwd ())) - let exec_dir: File.t = - (* Do not use Sys.executable_name, which may resolve symlinks: we want the original path. - (e.g. _build/install/default/bin/foo is a symlink) *) + let exec_dir : File.t = + (* Do not use Sys.executable_name, which may resolve symlinks: we want the + original path. (e.g. _build/install/default/bin/foo is a symlink) *) Filename.dirname Sys.argv.(0) - let clerk_exe: File.t Lazy.t = lazy Sys.executable_name + let clerk_exe : File.t Lazy.t = lazy Sys.executable_name - let catala_exe: File.t Lazy.t = lazy ( - let f = File.(exec_dir / "catala") in - if Sys.file_exists f then f else - match Lazy.force catala_project_root with - | Some root -> File.(root/"_build"/"default"/"compiler"/"catala.exe") - | None -> "catala" (* Dynamically resolved from PATH *) - ) + let catala_exe : File.t Lazy.t = + lazy + (let f = File.(exec_dir / "catala") in + if Sys.file_exists f then f + else + match Lazy.force catala_project_root with + | Some root -> + File.(root / "_build" / "default" / "compiler" / "catala.exe") + | None -> "catala" (* Dynamically resolved from PATH *)) - let build_dir: File.t Lazy.t = lazy ( - "_build" - (* Note: it could be safer here to use File.(Sys.getcwd () / "_build"), but Ninja treats relative and absolute paths separately so that you wouldn't then be able to build target _build/foo.ml but would have to write the full path every time *) - ) + let build_dir : File.t Lazy.t = lazy "_build" + (* Note: it could be safer here to use File.(Sys.getcwd () / "_build"), but + Ninja treats relative and absolute paths separately so that you wouldn't + then be able to build target _build/foo.ml but would have to write the full + path every time *) (* TODO: probably detect the project root and put this there instead *) (** Locates the main [lib] directory containing the OCaml libs *) - let ocaml_libdir: File.t Lazy.t = + let ocaml_libdir : File.t Lazy.t = lazy (try String.trim (File.process_out "opam" ["var"; "lib"]) with Failure _ -> ( - try String.trim (File.process_out "ocamlc" ["-where"]) - with Failure _ -> ( - match File.(check_directory (exec_dir /../ "lib")) with - | Some d -> d - | None -> - Message.raise_error - "Could not locate the OCaml library directory, make sure OCaml or \ - opam is installed"))) + try String.trim (File.process_out "ocamlc" ["-where"]) + with Failure _ -> ( + match File.(check_directory (exec_dir /../ "lib")) with + | Some d -> d + | None -> + Message.raise_error + "Could not locate the OCaml library directory, make sure OCaml \ + or opam is installed"))) (** Locates the directory containing the OCaml runtime to link to *) - let ocaml_runtime_dir: File.t Lazy.t = + let ocaml_runtime_dir : File.t Lazy.t = lazy (let d = match Lazy.force catala_project_root with @@ -350,61 +383,71 @@ module Poll = struct / "catala" / "runtime_ocaml") | None -> ( - match - File.check_directory - File.(exec_dir /../ "lib" / "catala" / "runtime_ocaml") - with - | Some d -> d - | None -> File.(Lazy.force ocaml_libdir / "catala" / "runtime")) + match + File.check_directory + File.(exec_dir /../ "lib" / "catala" / "runtime_ocaml") + with + | Some d -> d + | None -> File.(Lazy.force ocaml_libdir / "catala" / "runtime")) (* FIXME check this, not "runtime_ocaml" ?? *) in match File.check_directory d with | Some dir -> - Message.emit_debug "Catala runtime libraries found at @{%s@}." dir; + Message.emit_debug "Catala runtime libraries found at @{%s@}." + dir; dir | None -> Message.raise_error - "@[Could not locate the Catala runtime library.@ Make sure that \ - either catala is correctly installed,@ or you are running from the \ - root of a compiled source tree.@]") + "@[Could not locate the Catala runtime library.@ Make sure \ + that either catala is correctly installed,@ or you are running \ + from the root of a compiled source tree.@]") - let ocaml_link_flags: string list Lazy.t = lazy ( - let link_libs = - [ - "yojson"; - "ppx_yojson_conv_lib"; - "zarith"; - "dates_calc"; - ] - in - let link_libs_flags = - List.concat_map - (fun lib -> - match File.(check_directory (Lazy.force ocaml_libdir / lib)) with - | None -> - Message.raise_error - "Required OCaml library not found at %a.@ Try `opam \ - install %s'" - File.format File.(Lazy.force ocaml_libdir / lib) - lib - | Some d -> - ["-I"; d; String.map (function '-' -> '_' | c -> c) lib ^ ".cmxa"]) - link_libs - in - let runtime_dir = Lazy.force ocaml_runtime_dir in - link_libs_flags @ [File.(runtime_dir / "runtime_ocaml.cmxa")]) + let ocaml_link_flags : string list Lazy.t = + lazy + (let link_libs = + ["yojson"; "ppx_yojson_conv_lib"; "zarith"; "dates_calc"] + in + let link_libs_flags = + List.concat_map + (fun lib -> + match File.(check_directory (Lazy.force ocaml_libdir / lib)) with + | None -> + Message.raise_error + "Required OCaml library not found at %a.@ Try `opam install \ + %s'" + File.format + File.(Lazy.force ocaml_libdir / lib) + lib + | Some d -> + [ + "-I"; + d; + String.map (function '-' -> '_' | c -> c) lib ^ ".cmxa"; + ]) + link_libs + in + let runtime_dir = Lazy.force ocaml_runtime_dir in + link_libs_flags @ [File.(runtime_dir / "runtime_ocaml.cmxa")]) let has_command cmd = let check_cmd = Printf.sprintf "type %s >/dev/null 2>&1" cmd in Sys.command check_cmd = 0 - let diff_command = lazy ( - if has_command "patdiff" then - ["patdiff"; "-alt-old"; "reference"; "-alt-new"; "current-output"] - else - ["diff"; "-u"; "-b"; "--color"; "--label"; "referenec"; "--label"; "current-output"] - ) - + let diff_command = + lazy + (if has_command "patdiff" then + ["patdiff"; "-alt-old"; "reference"; "-alt-new"; "current-output"] + else + [ + "diff"; + "-u"; + "-b"; + "--color"; + "--label"; + "referenec"; + "--label"; + "current-output"; + ]) end (**{1 Building rules}*) @@ -418,7 +461,6 @@ module Var = struct let ninja_required_version = make "ninja_required_version" let builddir = make "builddir" let default = make "default" - let clerk_exe = make "CLERK_EXE" let catala_exe = make "CATALA_EXE" let catala_flags = make "CATALA_FLAGS" @@ -427,10 +469,10 @@ module Var = struct let ocamlopt_flags = make "OCAMLOPT_FLAGS" let runtime_ocaml_libs = make "RUNTIME_OCAML_LIBS" let diff = make "DIFF" - let module_dir module_name = make ("module_dir_" ^ module_name) - let module_src module_name = make ("module_src_" ^ module_name) + (** Source file of a given Catala module *) + let module_src module_name = make ("module_src_" ^ module_name) (** Rule vars, Used in specific rules *) @@ -440,259 +482,386 @@ module Var = struct let modules_src = make "modules_src" let modules_use = make "modules_use" let include_flags = make "include_flags" - let scope = make "scope" let test_id = make "test-id" let test_out = make "test-out" let test_command = make "test-command" - let ( ! ) = Var.v end let base_bindings catala_exe catala_flags = [ - Nj.binding Var.ninja_required_version ["1.7"]; (* use of implicit outputs *) - Nj.binding Var.builddir [Lazy.force Poll.build_dir]; - - Nj.binding Var.clerk_exe [Lazy.force Poll.clerk_exe]; - Nj.binding Var.catala_exe [match catala_exe with Some e -> e | None -> Lazy.force Poll.catala_exe]; - Nj.binding Var.catala_flags ("--build-dir" :: Var.(!builddir) :: catala_flags); - Nj.binding Var.clerk_flags ("-e" :: Var.(!catala_exe) :: (List.map (fun f -> "--catala-opts=" ^ f) catala_flags)); - Nj.binding Var.ocamlopt_exe ["ocamlopt"]; - Nj.binding Var.ocamlopt_flags ["-I"; Lazy.force Poll.ocaml_runtime_dir]; - Nj.binding Var.runtime_ocaml_libs (Lazy.force Poll.ocaml_link_flags); - Nj.binding Var.diff (Lazy.force Poll.diff_command); -] + Nj.binding Var.ninja_required_version ["1.7"]; + (* use of implicit outputs *) + Nj.binding Var.builddir [Lazy.force Poll.build_dir]; + Nj.binding Var.clerk_exe [Lazy.force Poll.clerk_exe]; + Nj.binding Var.catala_exe + [ + (match catala_exe with + | Some e -> e + | None -> Lazy.force Poll.catala_exe); + ]; + Nj.binding Var.catala_flags + ("--build-dir" :: Var.(!builddir) :: catala_flags); + Nj.binding Var.clerk_flags + ("-e" + :: Var.(!catala_exe) + :: List.map (fun f -> "--catala-opts=" ^ f) catala_flags); + Nj.binding Var.ocamlopt_exe ["ocamlopt"]; + Nj.binding Var.ocamlopt_flags ["-I"; Lazy.force Poll.ocaml_runtime_dir]; + Nj.binding Var.runtime_ocaml_libs (Lazy.force Poll.ocaml_link_flags); + Nj.binding Var.diff (Lazy.force Poll.diff_command); + ] let static_base_rules = let open Var in [ Nj.rule "ocaml" - ~command:[!catala_exe; "ocaml"; !catala_flags; !modules_src; !input; "-o"; !output] + ~command: + [ + !catala_exe; + "ocaml"; + !catala_flags; + !modules_src; + !input; + "-o"; + !output; + ] ~description:[""; "ocaml"; "⇒"; !output]; - Nj.rule "ocaml-module" - ~command:[!ocamlopt_exe; "-shared"; !include_flags; !ocamlopt_flags; !input; "-o"; !output] + ~command: + [ + !ocamlopt_exe; + "-shared"; + !include_flags; + !ocamlopt_flags; + !input; + "-o"; + !output; + ] ~description:[""; "⇒"; !output]; - Nj.rule "ocaml-exec" - ~command:[!ocamlopt_exe; !ocamlopt_flags; !runtime_ocaml_libs; !input; "-o"; !output] + ~command: + [ + !ocamlopt_exe; + !ocamlopt_flags; + !runtime_ocaml_libs; + !input; + "-o"; + !output; + ] ~description:[""; "⇒"; !output]; - Nj.rule "out-test" - ~command:[!catala_exe; !test_command; !catala_flags; !input; !modules_use; "2>&1"; "|"; !diff; !test_out; "/dev/stdin"] - ~description:[""; "test"; !test_id; "⇐"; !input; "("^ !test_command ^ ")"]; - + ~command: + [ + !catala_exe; + !test_command; + !catala_flags; + !input; + !modules_use; + "2>&1"; + "|"; + !diff; + !test_out; + "/dev/stdin"; + ] + ~description: + [""; "test"; !test_id; "⇐"; !input; "(" ^ !test_command ^ ")"]; Nj.rule "out-reset" - ~command:[!catala_exe; !test_command; !catala_flags; !input; !modules_use; ">"; !output; "2>&1"; "||"; "true"] - ~description:[""; "reset"; !test_id; "⇐"; !input; "("^ !test_command ^ ")"]; - + ~command: + [ + !catala_exe; + !test_command; + !catala_flags; + !input; + !modules_use; + ">"; + !output; + "2>&1"; + "||"; + "true"; + ] + ~description: + [""; "reset"; !test_id; "⇐"; !input; "(" ^ !test_command ^ ")"]; Nj.rule "inline-tests" - ~command:[!clerk_exe; "runtest"; !clerk_flags; "--catala-opts=--build-dir=" ^ !builddir; !input; !modules_use; "2>&1"; "|"; !diff; !input; "/dev/stdin"] + ~command: + [ + !clerk_exe; + "runtest"; + !clerk_flags; + "--catala-opts=--build-dir=" ^ !builddir; + !input; + !modules_use; + "2>&1"; + "|"; + !diff; + !input; + "/dev/stdin"; + ] ~description:[""; "inline-tests"; "⇐"; !input]; - Nj.rule "inline-reset" - ~command:[!clerk_exe; "runtest"; !clerk_flags; "--catala-opts=--build-dir=" ^ !builddir; !input; !modules_use; "--reset"] + ~command: + [ + !clerk_exe; + "runtest"; + !clerk_flags; + "--catala-opts=--build-dir=" ^ !builddir; + !input; + !modules_use; + "--reset"; + ] ~description:[""; "inline-reset"; "⇐"; !input]; - Nj.rule "interpret" - ~command:[!catala_exe; "interpret"; !catala_flags; !input; !modules_use; "--scope=" ^ !scope ] + ~command: + [ + !catala_exe; + "interpret"; + !catala_flags; + !input; + !modules_use; + "--scope=" ^ !scope; + ] ~description:[""; "interpret"; !scope; "⇐"; !input] ~vars:[pool, ["console"]]; ] -let gen_module_def (item: catala_build_item) : Nj.ninja = +let gen_module_def (item : catala_build_item) : Nj.ninja = match item.module_def with | None -> Seq.empty | Some modname -> - List.to_seq [ - Nj.binding (Var.module_dir modname) [Filename.dirname item.file_name]; - Nj.binding (Var.module_src modname) [Filename.basename item.file_name]; - ] + List.to_seq + [ + Nj.binding (Var.module_dir modname) [Filename.dirname item.file_name]; + Nj.binding (Var.module_src modname) [Filename.basename item.file_name]; + ] -let gen_build_statements (item: catala_build_item) : Nj.ninja = +let gen_build_statements (item : catala_build_item) : Nj.ninja = let open File in let ( ! ) = Var.( ! ) in let src = item.file_name in let modules = List.rev item.used_modules in - let header = - Nj.comment ("\nDefinitions from " ^ src) - in + let header = Nj.comment ("\nDefinitions from " ^ src) in let ocaml = - Nj.build "ocaml" - ~inputs:[src] - ~implicit_in:((if modules = [] then [] else [!Var.modules_src]) @ item.included_files) - ~outputs:[!Var.builddir / src -.- "ml"] - ~vars:(if modules = [] then [] else - [Var.modules_src, - List.map (fun m -> !(Var.module_dir m) / !(Var.module_src m)) modules]) + Nj.build "ocaml" ~inputs:[src] + ~implicit_in: + ((if modules = [] then [] else [!Var.modules_src]) @ item.included_files) + ~outputs:[(!Var.builddir / src) -.- "ml"] + ~vars: + (if modules = [] then [] + else + [ + ( Var.modules_src, + List.map + (fun m -> !(Var.module_dir m) / !(Var.module_src m)) + modules ); + ]) in let ocamlopt = - let target ext = match item.module_def with - | Some m -> !Var.builddir / src /../ m ^ "." ^ ext - | None -> !Var.builddir / src -.- ext + let target ext = + match item.module_def with + | Some m -> (!Var.builddir / src /../ m) ^ "." ^ ext + | None -> (!Var.builddir / src) -.- ext in let implicit_out = - [target "cmi"; target "cmx"; (* target "cmt"; target "o" *)] + [target "cmi"; target "cmx" (* target "cmt"; target "o" *)] + in + let vars = + [Var.include_flags, ["-I"; !Var.builddir / Filename.dirname src]] in - let vars = [Var.include_flags, ["-I"; !Var.builddir / Filename.dirname src]] in match item.module_def with | Some _ -> Nj.build "ocaml-module" - ~inputs:[!Var.builddir / src -.- "ml"] - ~implicit_in:(List.map (fun m -> src /../ m ^ ".cmi") modules) + ~inputs:[(!Var.builddir / src) -.- "ml"] + ~implicit_in:(List.map (fun m -> (src /../ m) ^ ".cmi") modules) ~outputs:[target "cmxs"] - ~implicit_out - ~vars + ~implicit_out ~vars | None -> let inputs = - List.map (fun m -> !Var.builddir / src /../ m ^ ".cmx") modules @ - [ !Var.builddir / src -.- "ml" ] + List.map (fun m -> (!Var.builddir / src /../ m) ^ ".cmx") modules + @ [(!Var.builddir / src) -.- "ml"] in - Nj.build "ocaml-exec" - ~inputs - ~outputs:[target "exe"] - ~implicit_out - ~vars + Nj.build "ocaml-exec" ~inputs ~outputs:[target "exe"] ~implicit_out ~vars in let interpret_deps = Nj.build "phony" ~outputs:["interpret-deps@" ^ src] - ~inputs:( - item.included_files @ - List.map (fun m -> !(Var.module_dir m) / !(Var.module_src m)) modules @ - List.map (fun m -> !Var.builddir / !(Var.module_dir m) / m ^ ".cmxs") modules - ) + ~inputs: + (item.included_files + @ List.map (fun m -> !(Var.module_dir m) / !(Var.module_src m)) modules + @ List.map + (fun m -> (!Var.builddir / !(Var.module_dir m) / m) ^ ".cmxs") + modules) in let interpret = Nj.build "interpret" ~outputs:["interpret@" ^ src] ~inputs:[src] ~implicit_in:["interpret-deps@" ^ src] - ~vars:(if item.used_modules = [] then [] else [ - Var.modules_use, List.map (fun m -> "--use=" ^ !(Var.module_dir m) / !(Var.module_src m)) item.used_modules - ]) + ~vars: + (if item.used_modules = [] then [] + else + [ + ( Var.modules_use, + List.map + (fun m -> + "--use=" ^ (!(Var.module_dir m) / !(Var.module_src m))) + item.used_modules ); + ]) in let tests = let inputs = [src] in let implicit_in = ["interpret-deps@" ^ src] in let vars = - if item.used_modules = [] then [] else [ - Var.modules_use, List.map (fun m -> "--catala-opts=--use=" ^ !(Var.module_dir m) / !(Var.module_src m)) item.used_modules - ] + if item.used_modules = [] then [] + else + [ + ( Var.modules_use, + List.map + (fun m -> + "--catala-opts=--use=" + ^ (!(Var.module_dir m) / !(Var.module_src m))) + item.used_modules ); + ] in let legacy_tests = - List.fold_left (fun acc test -> - let vars = vars @ [ - Var.test_id, [test.id]; - Var.test_command, test.cmd; - Var.test_out, [src /../ "output" / Filename.basename src -.- test.id]; - ] in - Nj.build "out-test" ~inputs ~implicit_in ~outputs:["outtest@"^src^"@"^test.id] ~vars :: - Nj.build "out-reset" ~inputs ~implicit_in ~outputs:[!Var.test_out] - ~implicit_out:["outtest-reset@"^src^"@"^test.id] ~vars :: - acc - ) + List.fold_left + (fun acc test -> + let vars = + vars + @ [ + Var.test_id, [test.id]; + Var.test_command, test.cmd; + ( Var.test_out, + [(src /../ "output" / Filename.basename src) -.- test.id] ); + ] + in + Nj.build "out-test" ~inputs ~implicit_in + ~outputs:["outtest@" ^ src ^ "@" ^ test.id] + ~vars + :: Nj.build "out-reset" ~inputs ~implicit_in ~outputs:[!Var.test_out] + ~implicit_out:["outtest-reset@" ^ src ^ "@" ^ test.id] + ~vars + :: acc) [] item.legacy_tests in let inline_tests = - if not item.has_inline_tests then [] else + if not item.has_inline_tests then [] + else [ - Nj.build "inline-tests" ~inputs ~implicit_in ~vars ~outputs:["inline@" ^ src]; - Nj.build "inline-reset" ~inputs ~implicit_in ~vars ~outputs:["inline-reset@" ^ src]; + Nj.build "inline-tests" ~inputs ~implicit_in ~vars + ~outputs:["inline@" ^ src]; + Nj.build "inline-reset" ~inputs ~implicit_in ~vars + ~outputs:["inline-reset@" ^ src]; ] in let tests = if item.legacy_tests = [] && not item.has_inline_tests then [] else - [Nj.build "phony" - ~outputs:["test@" ^ src] - ~inputs: - ((if item.has_inline_tests then - ["inline@" ^ item.file_name] - else []) @ - List.map (fun test -> - "outtest@" ^ item.file_name ^"@"^ test.id) - item.legacy_tests); - Nj.build "phony" - ~outputs:["test-reset@" ^ src] - ~inputs: - ((if item.has_inline_tests then - ["inline-reset@" ^ item.file_name] - else []) @ - List.map (fun test -> - "outtest-reset@" ^ item.file_name ^"@"^ test.id) - item.legacy_tests)] + [ + Nj.build "phony" + ~outputs:["test@" ^ src] + ~inputs: + ((if item.has_inline_tests then ["inline@" ^ item.file_name] + else []) + @ List.map + (fun test -> "outtest@" ^ item.file_name ^ "@" ^ test.id) + item.legacy_tests); + Nj.build "phony" + ~outputs:["test-reset@" ^ src] + ~inputs: + ((if item.has_inline_tests then ["inline-reset@" ^ item.file_name] + else []) + @ List.map + (fun test -> + "outtest-reset@" ^ item.file_name ^ "@" ^ test.id) + item.legacy_tests); + ] in legacy_tests @ inline_tests @ tests in - Seq.concat @@ List.to_seq [ - Seq.return header; - Seq.return ocaml; - Seq.return ocamlopt; - Seq.return interpret_deps; - List.to_seq tests; - Seq.return interpret; - ] + Seq.concat + @@ List.to_seq + [ + Seq.return header; + Seq.return ocaml; + Seq.return ocamlopt; + Seq.return interpret_deps; + List.to_seq tests; + Seq.return interpret; + ] let test_targets_by_dir items = - let stmt target_pfx dir sub = Nj.build "phony" ~outputs:[target_pfx ^ dir] + let stmt target_pfx dir sub = + Nj.build "phony" + ~outputs:[target_pfx ^ dir] ~inputs:(List.map (( ^ ) target_pfx) sub) in let alias dir sub = - List.to_seq [ stmt "test@" dir sub; stmt "test-reset@" dir sub; Nj.comment "" ] + List.to_seq + [stmt "test@" dir sub; stmt "test-reset@" dir sub; Nj.comment ""] in - (* This relies on the fact that the sequence is returned ordered by directory *) + (* This relies on the fact that the sequence is returned ordered by + directory *) let rec aux curdir seq = let prefix = if curdir = "" then "" else curdir ^ "/" in match seq () with - | Seq.Cons (item, seq) as node when - String.starts_with ~prefix item.file_name -> - if item.legacy_tests = [] && not item.has_inline_tests then aux curdir seq else - (match String.split_on_char '/' (String.remove_prefix ~prefix item.file_name) with - | [] -> assert false - | [_] -> - let rules, cur, seq = aux curdir seq in - rules, (item.file_name :: cur), seq - | subdir :: _ -> - let subdir = File.(curdir / subdir) in - let rules, sub, seq = aux subdir (fun () -> node) in - let rules = - if sub = [] then rules else - Seq.append rules (alias subdir sub) - in - let rules1, cur, seq = aux curdir seq in - Seq.append rules rules1, - (subdir :: cur), - seq) - | node -> Seq.empty, [], (fun () -> node) + | Seq.Cons (item, seq) as node + when String.starts_with ~prefix item.file_name -> ( + if item.legacy_tests = [] && not item.has_inline_tests then aux curdir seq + else + match + String.split_on_char '/' (String.remove_prefix ~prefix item.file_name) + with + | [] -> assert false + | [_] -> + let rules, cur, seq = aux curdir seq in + rules, item.file_name :: cur, seq + | subdir :: _ -> + let subdir = File.(curdir / subdir) in + let rules, sub, seq = aux subdir (fun () -> node) in + let rules = + if sub = [] then rules else Seq.append rules (alias subdir sub) + in + let rules1, cur, seq = aux curdir seq in + Seq.append rules rules1, subdir :: cur, seq) + | node -> Seq.empty, [], fun () -> node in let rules, top, seq = aux "" items in assert (Seq.is_empty seq); - Seq.append rules @@ List.to_seq [ - Nj.build "phony" ~outputs:["test"] ~inputs:(List.map (( ^ ) "test@") top); - Nj.build "phony" ~outputs:["test-reset"] ~inputs:(List.map (( ^ ) "test-reset@") top); - ] + Seq.append rules + @@ List.to_seq + [ + Nj.build "phony" ~outputs:["test"] + ~inputs:(List.map (( ^ ) "test@") top); + Nj.build "phony" ~outputs:["test-reset"] + ~inputs:(List.map (( ^ ) "test-reset@") top); + ] let build_statements dir = - (* Unfortunately we need to express the module name bindings first, so need to iterate twice using Seq.memoize *) - scan_tree dir |> Seq.memoize |> fun items -> - Seq.concat @@ List.to_seq [ - Seq.flat_map gen_module_def items; - Seq.flat_map gen_build_statements items; - Seq.return (Nj.comment "\n- Global targets - #\n"); - test_targets_by_dir items; - ] + (* Unfortunately we need to express the module name bindings first, so need to + iterate twice using Seq.memoize *) + scan_tree dir + |> Seq.memoize + |> fun items -> + Seq.concat + @@ List.to_seq + [ + Seq.flat_map gen_module_def items; + Seq.flat_map gen_build_statements items; + Seq.return (Nj.comment "\n- Global targets - #\n"); + test_targets_by_dir items; + ] let gen_ninja_file catala_exe catala_flags dir = let ( @+ ) = Seq.append in - Seq.return (Nj.Comment (Printf.sprintf "File generated by Clerk v.%s\n" version)) @+ - Seq.return (Nj.Comment "- Global variables - #\n") @+ - List.to_seq (base_bindings catala_exe catala_flags) @+ - Seq.return (Nj.Comment "- Base rules - #\n") @+ - List.to_seq static_base_rules @+ - Seq.return (Nj.Comment "- Project-specific build statements - #") @+ - build_statements dir + Seq.return + (Nj.Comment (Printf.sprintf "File generated by Clerk v.%s\n" version)) + @+ Seq.return (Nj.Comment "- Global variables - #\n") + @+ List.to_seq (base_bindings catala_exe catala_flags) + @+ Seq.return (Nj.Comment "- Base rules - #\n") + @+ List.to_seq static_base_rules + @+ Seq.return (Nj.Comment "- Project-specific build statements - #") + @+ build_statements dir (**{1 Running}*) @@ -718,8 +887,7 @@ let return_err = 1 (** {1 Driver} *) let ninja_init ~chdir ~catala_exe ~catala_opts ~color ~debug ~ninja_output : - extra:def Seq.t -> (File.t -> 'a) -> 'a - = + extra:def Seq.t -> (File.t -> 'a) -> 'a = Option.iter Sys.chdir chdir; let _options = Catala_utils.Cli.enforce_globals ~debug ~color () in let with_ninja_output k = @@ -733,11 +901,13 @@ let ninja_init ~chdir ~catala_exe ~catala_opts ~color ~debug ~ninja_output : @@ fun nin_file -> File.with_formatter_of_file nin_file (fun nin_ppf -> let ninja_contents = - Seq.concat @@ List.to_seq [ - gen_ninja_file catala_exe catala_opts "."; - Seq.return (Nj.comment "\n - Command-specific targets - #"); - extra - ] + Seq.concat + @@ List.to_seq + [ + gen_ninja_file catala_exe catala_opts "."; + Seq.return (Nj.comment "\n - Command-specific targets - #"); + extra; + ] in Nj.format nin_ppf ninja_contents); k nin_file @@ -745,11 +915,9 @@ let ninja_init ~chdir ~catala_exe ~catala_opts ~color ~debug ~ninja_output : open Cmdliner let build_cmd = - let run ninja_init - (targets : string list) - (ninja_flags : string) - = - ninja_init ~extra:Seq.empty @@ fun nin_file -> + let run ninja_init (targets : string list) (ninja_flags : string) = + ninja_init ~extra:Seq.empty + @@ fun nin_file -> let ninja_cmd = String.concat " " (["ninja -k 0 -f"; nin_file; ninja_flags] @ targets) in @@ -757,18 +925,19 @@ let build_cmd = Sys.command ninja_cmd in let doc = - "Low-level build command: can be used to forward build targets or options directly to Ninja" + "Low-level build command: can be used to forward build targets or options \ + directly to Ninja" in - Cmd.v - (Cmd.info ~doc "build") - Term.(const run $ Cli.Global.term ninja_init $ Cli.targets $ Cli.ninja_flags) + Cmd.v (Cmd.info ~doc "build") + Term.( + const run $ Cli.Global.term ninja_init $ Cli.targets $ Cli.ninja_flags) let test_cmd = - let run ninja_init + let run + ninja_init (files_or_folders : string list) (reset_test_outputs : bool) - (ninja_flags : string) - = + (ninja_flags : string) = let targets = let target = if reset_test_outputs then "test-reset" else "test" in match files_or_folders with @@ -776,7 +945,8 @@ let test_cmd = | files -> List.map (fun f -> target ^ "@" ^ f) files in let extra = Seq.return (Nj.default targets) in - ninja_init ~extra @@ fun nin_file -> + ninja_init ~extra + @@ fun nin_file -> let ninja_cmd = String.concat " " ["ninja -k 0 -f"; nin_file; ninja_flags] in @@ -784,24 +954,34 @@ let test_cmd = Sys.command ninja_cmd in let doc = - "Scan the given files or directories for catala tests, build their requirement and run them all. With $(b,--reset) the expected results are updated in-place ; otherwise, 0 is returned if the output matches the reference, or 1 is returned and a diff is printed to stdout" + "Scan the given files or directories for catala tests, build their \ + requirement and run them all. With $(b,--reset) the expected results are \ + updated in-place ; otherwise, 0 is returned if the output matches the \ + reference, or 1 is returned and a diff is printed to stdout" in - Cmd.v - (Cmd.info ~doc "test") - Term.(const run $ Cli.Global.term ninja_init $ Cli.files_or_folders $ Cli.reset_test_outputs $ Cli.ninja_flags) + Cmd.v (Cmd.info ~doc "test") + Term.( + const run + $ Cli.Global.term ninja_init + $ Cli.files_or_folders + $ Cli.reset_test_outputs + $ Cli.ninja_flags) let run_cmd = - let run ninja_init + let run + ninja_init (files_or_folders : string list) - (scope: string) - (ninja_flags : string) - = + (scope : string) + (ninja_flags : string) = let extra = - Seq.cons (Nj.binding Var.scope [scope]) + Seq.cons + (Nj.binding Var.scope [scope]) (Seq.return - (Nj.default (List.map (fun file -> "interpret@"^file) files_or_folders))) + (Nj.default + (List.map (fun file -> "interpret@" ^ file) files_or_folders))) in - ninja_init ~extra @@ fun nin_file -> + ninja_init ~extra + @@ fun nin_file -> let ninja_cmd = String.concat " " ["ninja -k 0 -f"; nin_file; ninja_flags] in @@ -809,11 +989,17 @@ let run_cmd = Sys.command ninja_cmd in let doc = - "Runs the Catala interpreter on the given files, after building their dependencies. The scope to be executed must be specified using the $(i,-s) option." + "Runs the Catala interpreter on the given files, after building their \ + dependencies. The scope to be executed must be specified using the \ + $(i,-s) option." in - Cmd.v - (Cmd.info ~doc "run") - Term.(const run $ Cli.Global.term ninja_init $ Cli.files_or_folders $ Cli.scope $ Cli.ninja_flags) + Cmd.v (Cmd.info ~doc "run") + Term.( + const run + $ Cli.Global.term ninja_init + $ Cli.files_or_folders + $ Cli.scope + $ Cli.ninja_flags) let runtest_cmd = let run catala_exe catala_opts reset file = @@ -823,14 +1009,16 @@ let runtest_cmd = 0 in let doc = - "Mainly for internal purposes. Runs inline tests from a Catala file, and outputs their results to stdout" + "Mainly for internal purposes. Runs inline tests from a Catala file, and \ + outputs their results to stdout" in - Cmd.v - (Cmd.info ~doc "runtest") - Term.(const run $ Cli.catala_exe $ Cli.catala_opts $ Cli.reset_test_outputs $ Cli.single_file) - -let main_cmd = - Cmd.group Cli.info [build_cmd; test_cmd; run_cmd; runtest_cmd] + Cmd.v (Cmd.info ~doc "runtest") + Term.( + const run + $ Cli.catala_exe + $ Cli.catala_opts + $ Cli.reset_test_outputs + $ Cli.single_file) +let main_cmd = Cmd.group Cli.info [build_cmd; test_cmd; run_cmd; runtest_cmd] let main () = exit (Cmdliner.Cmd.eval' main_cmd) - diff --git a/build_system/clerk_runtest.ml b/build_system/clerk_runtest.ml index 9e2b0e94..51702da4 100644 --- a/build_system/clerk_runtest.ml +++ b/build_system/clerk_runtest.ml @@ -196,7 +196,8 @@ let run_inline_tests output_string oc test.text_before; let cmd_out_rd, cmd_out_wr = Unix.pipe () in let ic = Unix.in_channel_of_descr cmd_out_rd in - (* let file_dir, file = Filename.dirname file, Filename.basename file in *) + (* let file_dir, file = Filename.dirname file, Filename.basename file + 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. *) @@ -206,8 +207,10 @@ let run_inline_tests in let cmd = match test.params with - | cmd0 :: flags -> Array.of_list (catala_exe :: cmd0 :: catala_opts @ flags @ [file]) - | [] -> Array.of_list (catala_exe :: catala_opts @ [file]) + | cmd0 :: flags -> + Array.of_list + ((catala_exe :: cmd0 :: catala_opts) @ flags @ [file]) + | [] -> Array.of_list ((catala_exe :: catala_opts) @ [file]) in let env = Unix.environment () @@ -236,7 +239,9 @@ let run_inline_tests Unix.close cmd_out_wr; let rec process_cmd_out () = let s = input_line ic in - let s = Re.(replace_string (compile (str File.(file /../ ""))) ~by:"" s) in + let s = + Re.(replace_string (compile (str File.(file /../ ""))) ~by:"" s) + in if s = "```" || String.starts_with ~prefix:"#return code" s then output_char oc '\\'; let rec trail s i = diff --git a/build_system/ninja_utils.ml b/build_system/ninja_utils.ml index 4831a201..400c88a5 100644 --- a/build_system/ninja_utils.ml +++ b/build_system/ninja_utils.ml @@ -19,11 +19,8 @@ module Var = struct type t = V of string let make s = V s - let name (V v) = v - let v (V v) = Printf.sprintf "${%s}" v - end module Expr = struct @@ -33,18 +30,18 @@ module Expr = struct Format.pp_print_list ~pp_sep:(fun fmt () -> Format.pp_print_char fmt ' ') (fun fmt s -> - Format.pp_print_string fmt - (Re.replace_string Re.(compile space) ~by:"$ " s)) + Format.pp_print_string fmt + (Re.replace_string Re.(compile space) ~by:"$ " s)) end module Binding = struct type t = Var.t * Expr.t + let make var e = var, e + let format ~global ppf (v, e) = if not global then Format.pp_print_string ppf " "; - Format.fprintf ppf "%s = %a" - (Var.name v) - Expr.format e; + Format.fprintf ppf "%s = %a" (Var.name v) Expr.format e; if global then Format.pp_print_newline ppf () let format_list ~global ppf l = @@ -52,19 +49,29 @@ module Binding = struct end module Rule = struct - type t = { name : string; command : Expr.t; description : Expr.t option; vars : Binding.t list } + type t = { + name : string; + command : Expr.t; + description : Expr.t option; + vars : Binding.t list; + } - let make ?(vars=[]) name ~command ~description = + let make ?(vars = []) name ~command ~description = { name; command; description = Option.some description; vars } let format fmt rule = let bindings = - Binding.make (Var.make "command") rule.command :: - Option.(to_list (map (fun d -> Binding.make (Var.make "description") d) rule.description)) @ - rule.vars + Binding.make (Var.make "command") rule.command + :: Option.( + to_list + (map + (fun d -> Binding.make (Var.make "description") d) + rule.description)) + @ rule.vars in - Format.fprintf fmt "rule %s\n%a" - rule.name (Binding.format_list ~global:false) bindings + Format.fprintf fmt "rule %s\n%a" rule.name + (Binding.format_list ~global:false) + bindings end module Build = struct @@ -77,7 +84,8 @@ module Build = struct vars : Binding.t list; } - let make ?inputs ?(implicit_in=[]) ~outputs ?implicit_out ?(vars=[]) rule = + let make ?inputs ?(implicit_in = []) ~outputs ?implicit_out ?(vars = []) rule + = { rule; inputs; implicit_in; outputs; implicit_out; vars } let empty = make ~outputs:["empty"] "phony" @@ -86,52 +94,66 @@ module Build = struct Re.Pcre.(substitute ~rex:(regexp "/") ~subst:(fun _ -> sep)) path let format fmt t = - Format.fprintf fmt "build %a%a: %s%a%a%a%a" - Expr.format t.outputs - (Format.pp_print_option - (fun fmt i -> - Format.pp_print_string fmt " | "; - Expr.format fmt i)) - t.implicit_out - t.rule - (Format.pp_print_option - (fun ppf e -> Format.pp_print_char ppf ' '; Expr.format ppf e)) + Format.fprintf fmt "build %a%a: %s%a%a%a%a" Expr.format t.outputs + (Format.pp_print_option (fun fmt i -> + Format.pp_print_string fmt " | "; + Expr.format fmt i)) + t.implicit_out t.rule + (Format.pp_print_option (fun ppf e -> + Format.pp_print_char ppf ' '; + Expr.format ppf e)) t.inputs - (fun ppf -> function [] -> () | e -> Format.pp_print_string ppf " | "; Expr.format ppf e) + (fun ppf -> function + | [] -> () + | e -> + Format.pp_print_string ppf " | "; + Expr.format ppf e) t.implicit_in - (if t.vars = [] then fun _ () -> () else Format.pp_print_newline) () + (if t.vars = [] then fun _ () -> () else Format.pp_print_newline) + () (Binding.format_list ~global:false) t.vars end module Default = struct type t = Expr.t + let make rules = rules let format ppf t = Format.fprintf ppf "default %a" Expr.format t end -type def = Comment of string | Binding of Binding.t | Rule of Rule.t | Build of Build.t | Default of Default.t +type def = + | Comment of string + | Binding of Binding.t + | Rule of Rule.t + | Build of Build.t + | Default of Default.t let comment s = Comment s let binding v e = Binding (Binding.make v e) + let rule ?vars name ~command ~description = Rule (Rule.make ?vars name ~command ~description) + let build ?inputs ?implicit_in ~outputs ?implicit_out ?vars rule = Build (Build.make ?inputs ?implicit_in ~outputs ?implicit_out ?vars rule) -let default rules = - Default (Default.make rules) + +let default rules = Default (Default.make rules) let format_def ppf def = - let () = match def with + let () = + match def with | Comment s -> Format.pp_print_list ~pp_sep:Format.pp_print_newline (fun ppf s -> - if s <> "" then Format.pp_print_string ppf "# "; - Format.pp_print_string ppf s) + if s <> "" then Format.pp_print_string ppf "# "; + Format.pp_print_string ppf s) ppf (String.split_on_char '\n' s) | Binding b -> Binding.format ~global:true ppf b - | Rule r -> Rule.format ppf r; Format.pp_print_newline ppf () + | Rule r -> + Rule.format ppf r; + Format.pp_print_newline ppf () | Build b -> Build.format ppf b | Default d -> Default.format ppf d in diff --git a/build_system/ninja_utils.mli b/build_system/ninja_utils.mli index 4c6b2011..c53c8a93 100644 --- a/build_system/ninja_utils.mli +++ b/build_system/ninja_utils.mli @@ -34,35 +34,37 @@ (** {1 Ninja expressions} *) -(** Ninja variable names, distinguishing binding name ("x") from references in expressions ("$x") *) +(** Ninja variable names, distinguishing binding name ("x") from references in + expressions ("$x") *) module Var : sig type t - val make: string -> t + val make : string -> t + val name : t -> string (** Var base name, used when binding it *) - val name: t -> string + val v : t -> string (** Var reference with a preceding "$", for use in expressoins *) - val v: t -> string end - (** Helper module to build ninja expressions. *) module Expr : sig - (** Ninja expressions are represented as raw string lists, which may contain variables or "$-escapes" *) type t = string list + (** Ninja expressions are represented as raw string lists, which may contain + variables or "$-escapes" *) val format : Format.formatter -> t -> unit (** [format fmt exp] outputs in [fmt] the string representation of the ninja - expression [exp]. Spaces in individual elements are escaped (but no check is made for e.g. newlines) *) - + expression [exp]. Spaces in individual elements are escaped (but no check + is made for e.g. newlines) *) end module Binding : sig type t = Var.t * Expr.t - val make: Var.t -> Expr.t -> t - val format: global:bool -> Format.formatter -> t -> unit + + val make : Var.t -> Expr.t -> t + val format : global:bool -> Format.formatter -> t -> unit end (** {1 Ninja rules} *) @@ -79,7 +81,8 @@ module Rule : sig [description = ] ]} *) - val make : ?vars:Binding.t list -> string -> command:Expr.t -> description:Expr.t -> t + val make : + ?vars:Binding.t list -> string -> command:Expr.t -> description:Expr.t -> t (** [make name ~command ~description] returns the corresponding ninja {!type:Rule.t}. *) @@ -125,18 +128,27 @@ module Build : sig [build]. *) end -module Default: sig +module Default : sig type t - val make: Expr.t -> t - val format: Format.formatter -> t -> unit + + val make : Expr.t -> t + val format : Format.formatter -> t -> unit end -type def = Comment of string | Binding of Binding.t | Rule of Rule.t | Build of Build.t | Default of Default.t +type def = + | Comment of string + | Binding of Binding.t + | Rule of Rule.t + | Build of Build.t + | Default of Default.t -val comment: string -> def -val binding: Var.t -> Expr.t -> def -val rule: ?vars:Binding.t list -> string -> command:Expr.t -> description:Expr.t -> def -val build: +val comment : string -> def +val binding : Var.t -> Expr.t -> def + +val rule : + ?vars:Binding.t list -> string -> command:Expr.t -> description:Expr.t -> def + +val build : ?inputs:Expr.t -> ?implicit_in:Expr.t -> outputs:Expr.t -> @@ -144,10 +156,10 @@ val build: ?vars:(Var.t * Expr.t) list -> string -> def -val default: Expr.t -> def -val format_def: Format.formatter -> def -> unit +val default : Expr.t -> def +val format_def : Format.formatter -> def -> unit type ninja = def Seq.t -val format: Format.formatter -> ninja -> unit +val format : Format.formatter -> ninja -> unit diff --git a/compiler/catala_utils/cli.ml b/compiler/catala_utils/cli.ml index 18dc3913..f975bc2b 100644 --- a/compiler/catala_utils/cli.ml +++ b/compiler/catala_utils/cli.ml @@ -194,7 +194,11 @@ module Flags = struct let build_dir = value & opt (some string) None - & info ["build-dir"] ~docv:"DIR" ~doc:"Directory where build artefacts are expected to be found. This doesn't affect outptuts, but is used when looking up compiled modules." + & info ["build-dir"] ~docv:"DIR" + ~doc: + "Directory where build artefacts are expected to be found. This \ + doesn't affect outptuts, but is used when looking up compiled \ + modules." let disable_warnings = value @@ -330,7 +334,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 ae5f34f5..4aca040d 100644 --- a/compiler/catala_utils/cli.mli +++ b/compiler/catala_utils/cli.mli @@ -20,7 +20,7 @@ type backend_lang = En | Fr | Pl (** The usual auto/always/never option argument *) type when_enum = Auto | Always | Never -val when_opt: when_enum Cmdliner.Arg.conv +val when_opt : when_enum Cmdliner.Arg.conv type message_format_enum = | Human diff --git a/compiler/catala_utils/dune b/compiler/catala_utils/dune index d1d2f5c2..cbb4e44a 100644 --- a/compiler/catala_utils/dune +++ b/compiler/catala_utils/dune @@ -1,7 +1,15 @@ (library (name catala_utils) (public_name catala.catala_utils) - (libraries unix cmdliner ubase ocolor re bindlib catala.runtime_ocaml dune-build-info)) + (libraries + unix + cmdliner + ubase + ocolor + re + bindlib + catala.runtime_ocaml + dune-build-info)) (documentation (package catala) diff --git a/compiler/catala_utils/file.ml b/compiler/catala_utils/file.ml index 194a97db..6566ad46 100644 --- a/compiler/catala_utils/file.ml +++ b/compiler/catala_utils/file.ml @@ -121,14 +121,14 @@ let ( / ) = Filename.concat let dirname = Filename.dirname let ( /../ ) a b = dirname a / b let ( -.- ) file ext = Filename.chop_extension file ^ "." ^ ext - let equal = String.equal let compare = String.compare let format ppf t = Format.fprintf ppf "\"@{%s@}\"" t -module Set = Set.Make(struct - type nonrec t = t - let compare = compare +module Set = Set.Make (struct + type nonrec t = t + + let compare = compare end) let scan_tree f t = @@ -147,9 +147,7 @@ let scan_tree f t = |> do_files and do_files flist = let dirs, files = - flist - |> List.sort (fun a b -> -compare a b) - |> List.partition is_dir + flist |> List.sort (fun a b -> -compare a b) |> List.partition is_dir in Seq.append (Seq.concat (Seq.map do_dir (List.to_seq dirs))) diff --git a/compiler/catala_utils/file.mli b/compiler/catala_utils/file.mli index 8c3bdf50..644d06d0 100644 --- a/compiler/catala_utils/file.mli +++ b/compiler/catala_utils/file.mli @@ -96,7 +96,8 @@ val ( /../ ) : t -> t -> t (** Sugar for [Filename.dirname "a" / b] *) val ( -.- ) : t -> string -> t -(** Extension replacement: chops the given filename extension, and replaces it with the given one (which shouldn't contain a dot) *) +(** Extension replacement: chops the given filename extension, and replaces it + with the given one (which shouldn't contain a dot) *) val equal : t -> t -> bool (** String comparison no fancy file resolution *) @@ -108,7 +109,7 @@ val format : Format.formatter -> t -> unit (** Formats a filename in a consistent style, with double-quotes and color (when the output supports) *) -module Set: Set.S with type elt = t +module Set : Set.S with type elt = t val scan_tree : (t -> 'a option) -> t -> 'a Seq.t (** Recursively scans a directory for files. Directories or files matching ".*" diff --git a/compiler/catala_utils/uid.ml b/compiler/catala_utils/uid.ml index 52e0debd..3612bb12 100644 --- a/compiler/catala_utils/uid.ml +++ b/compiler/catala_utils/uid.ml @@ -95,14 +95,15 @@ module Module = struct let compare = Mark.compare String.compare let format ppf m = Format.fprintf ppf "@{%s@}" (Mark.remove m) end + include Ordering let to_string m = Mark.remove m let of_string m = m let pos m = Mark.get m - module Set = Set.Make(Ordering) - module Map = Map.Make(Ordering) + module Set = Set.Make (Ordering) + module Map = Map.Make (Ordering) end (* TODO: should probably be turned into an uid once we implement module import directives; that will incur an additional resolution work on all paths though diff --git a/compiler/catala_utils/uid.mli b/compiler/catala_utils/uid.mli index 2df50e7b..862b856c 100644 --- a/compiler/catala_utils/uid.mli +++ b/compiler/catala_utils/uid.mli @@ -75,7 +75,7 @@ module Module : sig val to_string : t -> string val format : Format.formatter -> t -> unit - val pos: t -> Pos.t + val pos : t -> Pos.t val equal : t -> t -> bool val compare : t -> t -> int val of_string : string * Pos.t -> t diff --git a/compiler/desugared/from_surface.ml b/compiler/desugared/from_surface.ml index 41c694e3..38c4faaf 100644 --- a/compiler/desugared/from_surface.ml +++ b/compiler/desugared/from_surface.ml @@ -172,8 +172,8 @@ let rec disambiguate_constructor let modname = ModuleName.of_string modname in match ModuleName.Map.find_opt modname ctxt.modules with | None -> - Message.raise_spanned_error (ModuleName.pos modname) "Module \"%a\" not found" - ModuleName.format modname + Message.raise_spanned_error (ModuleName.pos modname) + "Module \"%a\" not found" ModuleName.format modname | Some ctxt -> let constructor = List.map (Mark.map (fun (_, c) -> path, c)) constructor0 @@ -419,8 +419,8 @@ let rec translate_expr let modname = ModuleName.of_string modname in match ModuleName.Map.find_opt modname ctxt.modules with | None -> - Message.raise_spanned_error (ModuleName.pos modname) "Module \"%a\" not found" - ModuleName.format modname + Message.raise_spanned_error (ModuleName.pos modname) + "Module \"%a\" not found" ModuleName.format modname | Some ctxt -> get_str ctxt path) in Expr.edstructaccess ~e ~field:(Mark.remove x) @@ -1470,7 +1470,8 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) : { Ast.program_lang = surface.program_lang; Ast.program_module_name = - Option.map ModuleName.of_string surface.Surface.Ast.program_module_name; + Option.map ModuleName.of_string + surface.Surface.Ast.program_module_name; Ast.program_ctx = { (* After name resolution, type definitions (structs and enums) are @@ -1526,8 +1527,7 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) : (fun prgm child -> process_structure prgm child) prgm children | S.CodeBlock (block, _, _) -> process_code_block ctxt prgm block - | S.LawInclude _ | S.LawText _ - | S.ModuleUse _ | S.ModuleDef _ -> prgm + | S.LawInclude _ | S.LawText _ | S.ModuleUse _ | S.ModuleDef _ -> prgm in let desugared = List.fold_left diff --git a/compiler/desugared/linting.ml b/compiler/desugared/linting.ml index 5afb9671..1c3b6d68 100644 --- a/compiler/desugared/linting.ml +++ b/compiler/desugared/linting.ml @@ -103,123 +103,129 @@ let detect_unused_struct_fields (p : program) : unit = (* TODO: this analysis should be finer grained: a false negative is if the field is used to define itself, for passing data around but that never gets really used or defined. *) - if p.program_module_name <> None then () else (* Disabled on modules *) - let struct_fields_used = - Ast.fold_exprs - ~f:(fun struct_fields_used e -> - let rec structs_fields_used_expr e struct_fields_used = - match Mark.remove e with - | EDStructAccess { name_opt = Some name; e = e_struct; field } -> - let field = - StructName.Map.find name - (Ident.Map.find field p.program_ctx.ctx_struct_fields) - in - StructField.Set.add field - (structs_fields_used_expr e_struct struct_fields_used) - | EStruct { name = _; fields } -> - StructField.Map.fold - (fun field e_field struct_fields_used -> - StructField.Set.add field - (structs_fields_used_expr e_field struct_fields_used)) - fields struct_fields_used - | _ -> Expr.shallow_fold structs_fields_used_expr e struct_fields_used - in - structs_fields_used_expr e struct_fields_used) - ~init:StructField.Set.empty p - in - let scope_out_structs_fields = - ScopeName.Map.fold - (fun _ out_struct acc -> - ScopeVar.Map.fold - (fun _ field acc -> StructField.Set.add field acc) - out_struct.out_struct_fields acc) - p.program_ctx.ctx_scopes StructField.Set.empty - in - StructName.Map.iter - (fun s_name fields -> - if StructName.path s_name <> [] then - (* Only check structs from the current module *) - () - else if - (not (StructField.Map.is_empty fields)) - && StructField.Map.for_all - (fun field _ -> - (not (StructField.Set.mem field struct_fields_used)) - && not (StructField.Set.mem field scope_out_structs_fields)) - fields - then - Message.emit_spanned_warning - (snd (StructName.get_info s_name)) - "The structure \"%a\" is never used; maybe it's unnecessary?" - StructName.format s_name - else - StructField.Map.iter - (fun field _ -> - if - (not (StructField.Set.mem field struct_fields_used)) - && not (StructField.Set.mem field scope_out_structs_fields) - then - Message.emit_spanned_warning - (snd (StructField.get_info field)) - "The field \"%a\" of struct @{\"%a\"@} is never used; \ - maybe it's unnecessary?" - StructField.format field StructName.format s_name) - fields) - p.program_ctx.ctx_structs + if p.program_module_name <> None then () + else + (* Disabled on modules *) + let struct_fields_used = + Ast.fold_exprs + ~f:(fun struct_fields_used e -> + let rec structs_fields_used_expr e struct_fields_used = + match Mark.remove e with + | EDStructAccess { name_opt = Some name; e = e_struct; field } -> + let field = + StructName.Map.find name + (Ident.Map.find field p.program_ctx.ctx_struct_fields) + in + StructField.Set.add field + (structs_fields_used_expr e_struct struct_fields_used) + | EStruct { name = _; fields } -> + StructField.Map.fold + (fun field e_field struct_fields_used -> + StructField.Set.add field + (structs_fields_used_expr e_field struct_fields_used)) + fields struct_fields_used + | _ -> + Expr.shallow_fold structs_fields_used_expr e struct_fields_used + in + structs_fields_used_expr e struct_fields_used) + ~init:StructField.Set.empty p + in + let scope_out_structs_fields = + ScopeName.Map.fold + (fun _ out_struct acc -> + ScopeVar.Map.fold + (fun _ field acc -> StructField.Set.add field acc) + out_struct.out_struct_fields acc) + p.program_ctx.ctx_scopes StructField.Set.empty + in + StructName.Map.iter + (fun s_name fields -> + if StructName.path s_name <> [] then + (* Only check structs from the current module *) + () + else if + (not (StructField.Map.is_empty fields)) + && StructField.Map.for_all + (fun field _ -> + (not (StructField.Set.mem field struct_fields_used)) + && not (StructField.Set.mem field scope_out_structs_fields)) + fields + then + Message.emit_spanned_warning + (snd (StructName.get_info s_name)) + "The structure \"%a\" is never used; maybe it's unnecessary?" + StructName.format s_name + else + StructField.Map.iter + (fun field _ -> + if + (not (StructField.Set.mem field struct_fields_used)) + && not (StructField.Set.mem field scope_out_structs_fields) + then + Message.emit_spanned_warning + (snd (StructField.get_info field)) + "The field \"%a\" of struct @{\"%a\"@} is never \ + used; maybe it's unnecessary?" + StructField.format field StructName.format s_name) + fields) + p.program_ctx.ctx_structs let detect_unused_enum_constructors (p : program) : unit = - if p.program_module_name <> None then () else (* Disabled on modules *) - let enum_constructors_used = - Ast.fold_exprs - ~f:(fun enum_constructors_used e -> - let rec enum_constructors_used_expr e enum_constructors_used = - match Mark.remove e with - | EInj { name = _; e = e_enum; cons } -> - EnumConstructor.Set.add cons - (enum_constructors_used_expr e_enum enum_constructors_used) - | EMatch { e = e_match; name = _; cases } -> - let enum_constructors_used = - enum_constructors_used_expr e_match enum_constructors_used - in - EnumConstructor.Map.fold - (fun cons e_cons enum_constructors_used -> - EnumConstructor.Set.add cons - (enum_constructors_used_expr e_cons enum_constructors_used)) - cases enum_constructors_used - | _ -> - Expr.shallow_fold enum_constructors_used_expr e - enum_constructors_used - in - enum_constructors_used_expr e enum_constructors_used) - ~init:EnumConstructor.Set.empty p - in - EnumName.Map.iter - (fun e_name constructors -> - if EnumName.path e_name <> [] then - (* Only check enums from the current module *) - () - else if - EnumConstructor.Map.for_all - (fun cons _ -> - not (EnumConstructor.Set.mem cons enum_constructors_used)) - constructors - then - Message.emit_spanned_warning - (snd (EnumName.get_info e_name)) - "The enumeration \"%a\" is never used; maybe it's unnecessary?" - EnumName.format e_name - else - EnumConstructor.Map.iter - (fun constructor _ -> - if not (EnumConstructor.Set.mem constructor enum_constructors_used) - then - Message.emit_spanned_warning - (snd (EnumConstructor.get_info constructor)) - "The constructor \"%a\" of enumeration \"%a\" is never used; \ - maybe it's unnecessary?" - EnumConstructor.format constructor EnumName.format e_name) - constructors) - p.program_ctx.ctx_enums + if p.program_module_name <> None then () + else + (* Disabled on modules *) + let enum_constructors_used = + Ast.fold_exprs + ~f:(fun enum_constructors_used e -> + let rec enum_constructors_used_expr e enum_constructors_used = + match Mark.remove e with + | EInj { name = _; e = e_enum; cons } -> + EnumConstructor.Set.add cons + (enum_constructors_used_expr e_enum enum_constructors_used) + | EMatch { e = e_match; name = _; cases } -> + let enum_constructors_used = + enum_constructors_used_expr e_match enum_constructors_used + in + EnumConstructor.Map.fold + (fun cons e_cons enum_constructors_used -> + EnumConstructor.Set.add cons + (enum_constructors_used_expr e_cons enum_constructors_used)) + cases enum_constructors_used + | _ -> + Expr.shallow_fold enum_constructors_used_expr e + enum_constructors_used + in + enum_constructors_used_expr e enum_constructors_used) + ~init:EnumConstructor.Set.empty p + in + EnumName.Map.iter + (fun e_name constructors -> + if EnumName.path e_name <> [] then + (* Only check enums from the current module *) + () + else if + EnumConstructor.Map.for_all + (fun cons _ -> + not (EnumConstructor.Set.mem cons enum_constructors_used)) + constructors + then + Message.emit_spanned_warning + (snd (EnumName.get_info e_name)) + "The enumeration \"%a\" is never used; maybe it's unnecessary?" + EnumName.format e_name + else + EnumConstructor.Map.iter + (fun constructor _ -> + if + not (EnumConstructor.Set.mem constructor enum_constructors_used) + then + Message.emit_spanned_warning + (snd (EnumConstructor.get_info constructor)) + "The constructor \"%a\" of enumeration \"%a\" is never used; \ + maybe it's unnecessary?" + EnumConstructor.format constructor EnumName.format e_name) + constructors) + p.program_ctx.ctx_enums (* Reachability in a graph can be implemented as a simple fixpoint analysis with backwards propagation. *) diff --git a/compiler/desugared/name_resolution.ml b/compiler/desugared/name_resolution.ml index da5f4502..d5a3e535 100644 --- a/compiler/desugared/name_resolution.ml +++ b/compiler/desugared/name_resolution.ml @@ -258,8 +258,8 @@ let rec module_ctx ctxt path = let modname = ModuleName.of_string modname in match ModuleName.Map.find_opt modname ctxt.modules with | None -> - Message.raise_spanned_error (ModuleName.pos modname) "Module \"%a\" not found" - ModuleName.format modname + Message.raise_spanned_error (ModuleName.pos modname) + "Module \"%a\" not found" ModuleName.format modname | Some ctxt -> module_ctx ctxt path) (** {1 Declarations pass} *) diff --git a/compiler/driver.ml b/compiler/driver.ml index 77dcd418..3da8d9e7 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -46,12 +46,9 @@ let load_module_interfaces options program files = let module MS = ModuleName.Set in let to_set intf_list = MS.of_list - (List.map (fun (mname, _) -> ModuleName.of_string mname) - intf_list) - in - let used_modules = - to_set program.Surface.Ast.program_modules + (List.map (fun (mname, _) -> ModuleName.of_string mname) intf_list) in + let used_modules = to_set program.Surface.Ast.program_modules in let load_file f = let lang = get_lang options (FileName f) in let (mname, intf), using = @@ -62,38 +59,44 @@ let load_module_interfaces options program files = let module_interfaces = List.map load_file files in let rec check (required, acc) interfaces = let required, acc, remaining = - List.fold_left (fun (required, acc, skipped) ((modname, intf), using as modl) -> + List.fold_left + (fun (required, acc, skipped) (((modname, intf), using) as modl) -> if MS.mem modname required then let required = - List.fold_left (fun req m -> MS.add (ModuleName.of_string m) req) required using + List.fold_left + (fun req m -> MS.add (ModuleName.of_string m) req) + required using in - required, (((modname :> string Mark.pos), intf) :: acc), skipped - else - required, acc, (modl :: skipped)) - (required, acc, []) - interfaces + required, ((modname :> string Mark.pos), intf) :: acc, skipped + else required, acc, modl :: skipped) + (required, acc, []) interfaces in if List.length remaining < List.length interfaces then (* Loop until fixpoint *) check (required, acc) remaining - else - required, acc, remaining + else required, acc, remaining in let required, loaded, unused = check (used_modules, []) module_interfaces in let missing = - MS.diff required (MS.of_list (List.map (fun (m,_) -> ModuleName.of_string m) loaded)) in - if not (MS.is_empty missing) || unused <> [] then + MS.diff required + (MS.of_list (List.map (fun (m, _) -> ModuleName.of_string m) loaded)) + in + if (not (MS.is_empty missing)) || unused <> [] then Message.raise_multispanned_error - (List.map (fun m -> - Some (Format.asprintf "Required module not found: %a" + (List.map + (fun m -> + ( Some + (Format.asprintf "Required module not found: %a" + ModuleName.format m), + ModuleName.pos m )) + (ModuleName.Set.elements missing) + @ List.map + (fun ((m, _), _) -> + ( Some + (Format.asprintf "No use was found for this module: %a" ModuleName.format m), - ModuleName.pos m) - (ModuleName.Set.elements missing) @ - List.map (fun ((m, _), _) -> - Some (Format.asprintf "No use was found for this module: %a" - ModuleName.format m), - ModuleName.pos m) - unused) + ModuleName.pos m )) + unused) "Modules used from the program don't match the command-line"; loaded diff --git a/compiler/lcalc/closure_conversion.ml b/compiler/lcalc/closure_conversion.ml index 53e9f005..30379bee 100644 --- a/compiler/lcalc/closure_conversion.ml +++ b/compiler/lcalc/closure_conversion.ml @@ -356,9 +356,12 @@ let transform_closures_program (p : 'm program) : 'm program Bindlib.box = in Bindlib.box_apply (fun new_code_items -> - { code_items = new_code_items; decl_ctx = new_decl_ctx; + { + code_items = new_code_items; + decl_ctx = new_decl_ctx; module_name = p.module_name; - lang = p.lang; }) + lang = p.lang; + }) new_code_items (** {1 Hoisting closures}*) diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index b2352aff..3c357468 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -245,8 +245,9 @@ let format_exception (fmt : Format.formatter) (exc : except Mark.pos) : unit = | ConflictError -> let pos = Mark.get exc in Format.fprintf fmt - "(ConflictError@ @[{filename = \"%s\";@\nstart_line=%d;@ \ - start_column=%d;@ end_line=%d; end_column=%d;@ law_headings=%a}@])" + "(ConflictError@ @[{filename = \"%s\";@\n\ + start_line=%d;@ start_column=%d;@ end_line=%d; end_column=%d;@ \ + law_headings=%a}@])" (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos) @@ -647,7 +648,8 @@ let format_module_registration Format.pp_print_string fmt "let () ="; Format.pp_print_space fmt (); Format.pp_open_hvbox fmt 2; - Format.fprintf fmt "Runtime_ocaml.Runtime.register_module \"%a\"" ModuleName.format modname; + Format.fprintf fmt "Runtime_ocaml.Runtime.register_module \"%a\"" + ModuleName.format modname; Format.pp_print_space fmt (); Format.pp_open_vbox fmt 2; Format.pp_print_string fmt "[ "; diff --git a/compiler/plugins/modules.ml b/compiler/plugins/modules.ml index e1e203cc..ab2a711f 100644 --- a/compiler/plugins/modules.ml +++ b/compiler/plugins/modules.ml @@ -51,8 +51,7 @@ let gen_ocaml options link_modules optimize check_invariants main = in with_output @@ fun ppf -> - Lcalc.To_ocaml.format_program ppf ?exec_scope prg - type_ordering; + Lcalc.To_ocaml.format_program ppf ?exec_scope prg type_ordering; Option.get filename let run_process cmd args = @@ -130,9 +129,7 @@ let compile options link_modules optimize check_invariants = | _ -> Message.raise_error "Input must be a file name for this command" in let basename = String.uncapitalize_ascii modname in - let ml_file = - gen_ocaml options link_modules optimize check_invariants None - in + let ml_file = gen_ocaml options link_modules optimize check_invariants None in let flags = ["-I"; Lazy.force runtime_dir] in let shared_out = File.((ml_file /../ basename) ^ ".cmxs") in Message.emit_debug "Compiling OCaml shared object file @{%s@}..." diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index 3d40bd26..a07f2d11 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -949,19 +949,20 @@ let load_runtime_modules prg = prg.decl_ctx.ctx_modules; List.iter (fun m -> - let srcfile = Pos.get_file (ModuleName.pos m) in - let obj_file = - File.(srcfile /../ ModuleName.to_string m ^ ".cmo") - |> Dynlink.adapt_filename - in - let obj_file = match Cli.globals.build_dir with - | None -> obj_file - | Some d -> File.(d / obj_file) - in - try Dynlink.loadfile obj_file - with Dynlink.Error dl_err -> - Message.raise_error - "Could not load module %a, has it been suitably compiled?@;\ - <1 2>@[%a@]" ModuleName.format m Format.pp_print_text - (Dynlink.error_message dl_err)) + let srcfile = Pos.get_file (ModuleName.pos m) in + let obj_file = + File.((srcfile /../ ModuleName.to_string m) ^ ".cmo") + |> Dynlink.adapt_filename + in + let obj_file = + match Cli.globals.build_dir with + | None -> obj_file + | Some d -> File.(d / obj_file) + in + try Dynlink.loadfile obj_file + with Dynlink.Error dl_err -> + Message.raise_error + "Could not load module %a, has it been suitably compiled?@;\ + <1 2>@[%a@]" ModuleName.format m Format.pp_print_text + (Dynlink.error_message dl_err)) modules diff --git a/compiler/shared_ast/interpreter.mli b/compiler/shared_ast/interpreter.mli index 3f9c934a..d95cc387 100644 --- a/compiler/shared_ast/interpreter.mli +++ b/compiler/shared_ast/interpreter.mli @@ -73,5 +73,7 @@ val interpret_program_lcalc : the computed values for the scope variables of the executed scope. *) val load_runtime_modules : _ program -> unit -(** Dynlink the runtime modules required by the given program, in order to make them callable by the - interpreter. If Cli.globals.build_dir is specified, the runtime module names (as obtained by looking up the positions in the program's module bindings) are assumed to be relative and looked up there. *) +(** Dynlink the runtime modules required by the given program, in order to make + them callable by the interpreter. If Cli.globals.build_dir is specified, the + runtime module names (as obtained by looking up the positions in the + program's module bindings) are assumed to be relative and looked up there. *) diff --git a/compiler/surface/ast.ml b/compiler/surface/ast.ml index f62521b8..451b1855 100644 --- a/compiler/surface/ast.ml +++ b/compiler/surface/ast.ml @@ -320,8 +320,7 @@ and program = { program_module_name : uident Mark.pos option; program_items : law_structure list; program_source_files : (string[@opaque]) list; - program_modules : interface list; - (** Modules being used by the program *) + program_modules : interface list; (** Modules being used by the program *) program_lang : Cli.backend_lang; [@opaque] } diff --git a/compiler/surface/lexer_common.mli b/compiler/surface/lexer_common.mli index 9919a19f..4d277499 100644 --- a/compiler/surface/lexer_common.mli +++ b/compiler/surface/lexer_common.mli @@ -74,5 +74,7 @@ module type LocalisedLexer = sig depending of the current {!val:Surface.Lexer_common.context}. *) val lex_line : Sedlexing.lexbuf -> (string * line_token) option - (** Low-level lexer intended for dependency extraction. The whole line (including ["\n"] is always returned together with the token. [None] for EOF. *) + (** Low-level lexer intended for dependency extraction. The whole line + (including ["\n"] is always returned together with the token. [None] for + EOF. *) end diff --git a/compiler/surface/parser_driver.ml b/compiler/surface/parser_driver.ml index 213eaba1..d8b0c1a2 100644 --- a/compiler/surface/parser_driver.ml +++ b/compiler/surface/parser_driver.ml @@ -206,7 +206,8 @@ let localised_parser : Cli.backend_lang -> lexbuf -> Ast.source_file = function (** Lightweight lexer for dependency *) let lines (file : File.t) (language : Cli.backend_lang) = - let lex_line = match language with + let lex_line = + match language with | En -> Lexer_en.lex_line | Fr -> Lexer_fr.lex_line | Pl -> Lexer_pl.lex_line @@ -218,7 +219,9 @@ let lines (file : File.t) (language : Cli.backend_lang) = let rec aux () = match lex_line lexbuf with | Some line -> Seq.Cons (line, aux) - | None -> close_in input; Seq.Nil + | None -> + close_in input; + Seq.Nil in aux with exc -> @@ -267,58 +270,73 @@ and expand_includes let rprg = List.fold_left (fun acc command -> - match command with - | Ast.ModuleDef id -> - (match acc.Ast.program_module_name with - | None -> { acc with Ast.program_module_name = Some id } - | Some id2 -> - Message.raise_multispanned_error - [None, Mark.get id; None, Mark.get id2] - "Multiple definitions of the module name") - | Ast.ModuleUse (id, _alias) -> - { acc with - Ast.program_modules = (id, []) :: acc.Ast.program_modules; - Ast.program_items = command :: acc.Ast.program_items } - | 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 - let includ_program = parse_source_file (FileName sub_source) language in - let () = - includ_program.Ast.program_module_name |> Option.iter @@ fun id -> - Message.raise_multispanned_error - [ Some "File include", Mark.get inc_file; - Some "Module declaration", Mark.get id ] - "A file that declares a module cannot be used through the raw '@{> Include@}' directive. You should use it as a module with '@{> Use %a@}' instead." Uid.Module.format (Uid.Module.of_string id) - in - { - Ast.program_module_name = None; - Ast.program_source_files = - List.rev_append includ_program.program_source_files acc.Ast.program_source_files; - Ast.program_items = - List.rev_append includ_program.program_items acc.Ast.program_items; - Ast.program_modules = - List.rev_append includ_program.program_modules acc.Ast.program_modules; - Ast.program_lang = language; - } - | Ast.LawHeading (heading, commands') -> - let { - Ast.program_module_name; - Ast.program_items = commands'; - Ast.program_source_files = new_sources; - Ast.program_modules = new_modules; - Ast.program_lang = _; - } = - expand_includes source_file commands' language - in - { - Ast.program_module_name; - Ast.program_source_files = List.rev_append new_sources acc.Ast.program_source_files; - Ast.program_items = - Ast.LawHeading (heading, commands') :: acc.Ast.program_items; - Ast.program_modules = List.rev_append new_modules acc.Ast.program_modules; - Ast.program_lang = language; - } - | i -> { acc with Ast.program_items = i :: acc.Ast.program_items }) + match command with + | Ast.ModuleDef id -> ( + match acc.Ast.program_module_name with + | None -> { acc with Ast.program_module_name = Some id } + | Some id2 -> + Message.raise_multispanned_error + [None, Mark.get id; None, Mark.get id2] + "Multiple definitions of the module name") + | Ast.ModuleUse (id, _alias) -> + { + acc with + Ast.program_modules = (id, []) :: acc.Ast.program_modules; + Ast.program_items = command :: acc.Ast.program_items; + } + | 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 + let includ_program = + parse_source_file (FileName sub_source) language + in + let () = + includ_program.Ast.program_module_name + |> Option.iter + @@ fun id -> + Message.raise_multispanned_error + [ + Some "File include", Mark.get inc_file; + Some "Module declaration", Mark.get id; + ] + "A file that declares a module cannot be used through the raw \ + '@{> Include@}' directive. You should use it as a \ + module with '@{> Use %a@}' instead." + Uid.Module.format (Uid.Module.of_string id) + in + { + Ast.program_module_name = None; + Ast.program_source_files = + List.rev_append includ_program.program_source_files + acc.Ast.program_source_files; + Ast.program_items = + List.rev_append includ_program.program_items acc.Ast.program_items; + Ast.program_modules = + List.rev_append includ_program.program_modules + acc.Ast.program_modules; + Ast.program_lang = language; + } + | Ast.LawHeading (heading, commands') -> + let { + Ast.program_module_name; + Ast.program_items = commands'; + Ast.program_source_files = new_sources; + Ast.program_modules = new_modules; + Ast.program_lang = _; + } = + expand_includes source_file commands' language + in + { + Ast.program_module_name; + Ast.program_source_files = + List.rev_append new_sources acc.Ast.program_source_files; + Ast.program_items = + Ast.LawHeading (heading, commands') :: acc.Ast.program_items; + Ast.program_modules = + List.rev_append new_modules acc.Ast.program_modules; + Ast.program_lang = language; + } + | i -> { acc with Ast.program_items = i :: acc.Ast.program_items }) { Ast.program_module_name = None; Ast.program_source_files = []; @@ -336,25 +354,23 @@ and expand_includes Ast.program_modules = List.rev rprg.Ast.program_modules; } - (** {2 Handling interfaces} *) let get_interface program = let rec filter (req, acc) = function - | Ast.LawInclude _ | Ast.LawText _ | Ast.ModuleDef _ -> - req, acc + | Ast.LawInclude _ | Ast.LawText _ | Ast.ModuleDef _ -> req, acc | Ast.LawHeading (_, str) -> List.fold_left filter (req, acc) str - | Ast.ModuleUse (m, _) -> (m::req), acc + | Ast.ModuleUse (m, _) -> m :: req, acc | Ast.CodeBlock (code, _, true) -> - req, - List.fold_left - (fun acc -> function - | Ast.ScopeUse _, _ -> acc - | ((Ast.ScopeDecl _ | StructDecl _ | EnumDecl _), _) as e -> - e :: acc - | Ast.Topdef def, m -> - (Ast.Topdef { def with topdef_expr = None }, m) :: acc) - acc code + ( req, + List.fold_left + (fun acc -> function + | Ast.ScopeUse _, _ -> acc + | ((Ast.ScopeDecl _ | StructDecl _ | EnumDecl _), _) as e -> + e :: acc + | Ast.Topdef def, m -> + (Ast.Topdef { def with topdef_expr = None }, m) :: acc) + acc code ) | Ast.CodeBlock (_, _, false) -> (* Non-metadata blocks are ignored *) req, acc @@ -370,15 +386,15 @@ let load_interface source_file language = | Some mname -> mname | None -> Message.raise_error - "%s doesn't define a module name. It should contain a '@{> Module \ - %s@}' directive." + "%s doesn't define a module name. It should contain a '@{> \ + Module %s@}' directive." (match source_file with - | FileName s -> "File " ^ s - | Contents _ -> "Source input") + | FileName s -> "File " ^ s + | Contents _ -> "Source input") (match source_file with - | FileName s -> - String.capitalize_ascii Filename.(basename (remove_extension s)) - | Contents _ -> "Module_name") + | FileName s -> + String.capitalize_ascii Filename.(basename (remove_extension s)) + | Contents _ -> "Module_name") in let used_modules, intf = get_interface program in (modname, intf), used_modules diff --git a/compiler/surface/parser_driver.mli b/compiler/surface/parser_driver.mli index 0098565f..dd81b7d0 100644 --- a/compiler/surface/parser_driver.mli +++ b/compiler/surface/parser_driver.mli @@ -19,13 +19,17 @@ open Catala_utils -val lines : File.t -> Cli.backend_lang -> (string * Lexer_common.line_token) Seq.t +val lines : + File.t -> Cli.backend_lang -> (string * Lexer_common.line_token) Seq.t (** Raw file parser that doesn't interpret any includes and returns the flat law structure as is *) -val load_interface : Cli.input_file -> Cli.backend_lang -> Ast.interface * string Mark.pos list +val load_interface : + Cli.input_file -> Cli.backend_lang -> 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 *) val parse_top_level_file : Cli.input_file -> Cli.backend_lang -> Ast.program -(** Parses a catala file (handling file includes) and returns a program. Interfaces of the used modules are returned empty, use [load_interface] to fill them. *) +(** Parses a catala file (handling file includes) and returns a program. + Interfaces of the used modules are returned empty, use [load_interface] to + fill them. *)