diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index f8880a4d..400de1b1 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -481,7 +481,7 @@ let static_base_rules = ~description:[""; "inline-tests"; "⇐"; !input]; Nj.rule "inline-reset" - ~command:[!clerk_exe; "runtest"; !clerk_flags; !input; !modules_use; "--reset"] + ~command:[!clerk_exe; "runtest"; !clerk_flags; "--catala-opts=--build-dir=" ^ !builddir; !input; !modules_use; "--reset"] ~description:[""; "inline-reset"; "⇐"; !input] ] diff --git a/compiler/catala_utils/uid.ml b/compiler/catala_utils/uid.ml index bf16849f..52e0debd 100644 --- a/compiler/catala_utils/uid.ml +++ b/compiler/catala_utils/uid.ml @@ -88,11 +88,21 @@ module Gen (S : Style) () = Make (MarkedString) (S) () (* - Modules, paths and qualified idents - *) module Module = struct - include String + module Ordering = struct + type t = string Mark.pos - let to_string m = m - let format ppf m = Format.fprintf ppf "@{%s@}" m + let equal = Mark.equal String.equal + 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) 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 @@ -107,9 +117,9 @@ module Path = struct (fun ppf m -> Format.fprintf ppf "%a@{.@}" Module.format m) ppf p - let to_string p = String.concat "." p - let equal = List.equal String.equal - let compare = List.compare String.compare + let to_string p = String.concat "." (List.map Module.to_string p) + let equal = List.equal Module.equal + let compare = List.compare Module.compare end module QualifiedMarkedString = struct diff --git a/compiler/catala_utils/uid.mli b/compiler/catala_utils/uid.mli index 3eef6b77..2df50e7b 100644 --- a/compiler/catala_utils/uid.mli +++ b/compiler/catala_utils/uid.mli @@ -70,13 +70,15 @@ module Gen (S : Style) () : Id with type info = MarkedString.info (** {2 Handling of Uids with additional path information} *) module Module : sig - type t = private string (* TODO: this will become an uid at some point *) + type t = private string Mark.pos + (* TODO: this will become an uid at some point *) val to_string : t -> string val format : Format.formatter -> t -> unit + val pos: t -> Pos.t val equal : t -> t -> bool val compare : t -> t -> int - val of_string : string -> t + val of_string : string * Pos.t -> t module Set : Set.S with type elt = t module Map : Map.S with type key = t diff --git a/compiler/desugared/from_surface.ml b/compiler/desugared/from_surface.ml index 48a8172f..c16a7938 100644 --- a/compiler/desugared/from_surface.ml +++ b/compiler/desugared/from_surface.ml @@ -168,11 +168,11 @@ let rec disambiguate_constructor with EnumName.Map.Not_found _ -> Message.raise_spanned_error pos "Enum %s does not contain case %s" (Mark.remove enum) (Mark.remove constructor)) - | (modname, mpos) :: path -> ( + | modname :: path -> ( let modname = ModuleName.of_string modname in match ModuleName.Map.find_opt modname ctxt.modules with | None -> - Message.raise_spanned_error mpos "Module \"%a\" not found" + Message.raise_spanned_error (ModuleName.pos modname) "Module \"%a\" not found" ModuleName.format modname | Some ctxt -> let constructor = @@ -415,11 +415,11 @@ let rec translate_expr let rec get_str ctxt = function | [] -> None | [c] -> Some (Name_resolution.get_struct ctxt c) - | (modname, mpos) :: path -> ( + | modname :: path -> ( let modname = ModuleName.of_string modname in match ModuleName.Map.find_opt modname ctxt.modules with | None -> - Message.raise_spanned_error mpos "Module \"%a\" not found" + Message.raise_spanned_error (ModuleName.pos modname) "Module \"%a\" not found" ModuleName.format modname | Some ctxt -> get_str ctxt path) in @@ -1529,7 +1529,7 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) : in let desugared = List.fold_left - (fun acc ((id, _pos), intf) -> + (fun acc (id, intf) -> let id = ModuleName.of_string id in let modul = ModuleName.Map.find id acc.Ast.program_modules in let modul = diff --git a/compiler/desugared/name_resolution.ml b/compiler/desugared/name_resolution.ml index 3b7eca08..da5f4502 100644 --- a/compiler/desugared/name_resolution.ml +++ b/compiler/desugared/name_resolution.ml @@ -254,11 +254,11 @@ let get_scope ctxt id = let rec module_ctx ctxt path = match path with | [] -> ctxt - | (modname, mpos) :: path -> ( + | modname :: path -> ( let modname = ModuleName.of_string modname in match ModuleName.Map.find_opt modname ctxt.modules with | None -> - Message.raise_spanned_error mpos "Module \"%a\" not found" + Message.raise_spanned_error (ModuleName.pos modname) "Module \"%a\" not found" ModuleName.format modname | Some ctxt -> module_ctx ctxt path) @@ -338,11 +338,11 @@ let rec process_base_typ "Unknown type @{\"%s\"@}, not a struct or enum previously \ declared" ident) - | Surface.Ast.Named ((modul, mpos) :: path, id) -> ( + | Surface.Ast.Named (modul :: path, id) -> ( let modul = ModuleName.of_string modul in match ModuleName.Map.find_opt modul ctxt.modules with | None -> - Message.raise_spanned_error mpos + Message.raise_spanned_error (ModuleName.pos modul) "This refers to module %a, which was not found" ModuleName.format modul | Some mod_ctxt -> @@ -956,7 +956,7 @@ let empty_ctxt = } let import_module modules (name, intf) = - let mname = ModuleName.of_string (Mark.remove name) in + let mname = ModuleName.of_string name in let ctxt = { empty_ctxt with modules; path = [mname] } in let ctxt = List.fold_left process_name_item ctxt intf in let ctxt = List.fold_left process_decl_item ctxt intf in diff --git a/compiler/driver.ml b/compiler/driver.ml index 7620f607..c2b3b1e1 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -580,7 +580,7 @@ module Commands = struct let prg, ctx, _ = Passes.dcalc options ~link_modules ~optimize ~check_invariants in - Interpreter.load_runtime_modules link_modules; + Interpreter.load_runtime_modules prg; print_interpretation_results options Interpreter.interpret_program_dcalc prg (get_scope_uid ctx ex_scope) diff --git a/compiler/plugins/explain.ml b/compiler/plugins/explain.ml index dc7c8a85..dd3df927 100644 --- a/compiler/plugins/explain.ml +++ b/compiler/plugins/explain.ml @@ -1386,11 +1386,11 @@ let options = $ base_src_url) let run link_modules optimize ex_scope explain_options global_options = - Interpreter.load_runtime_modules link_modules; let prg, ctx, _ = Driver.Passes.dcalc global_options ~link_modules ~optimize ~check_invariants:false in + Interpreter.load_runtime_modules prg; let scope = Driver.Commands.get_scope_uid ctx ex_scope in (* let result_expr, env = interpret_program prg scope in *) let g, base_vars, env = program_to_graph explain_options prg scope in diff --git a/compiler/plugins/lazy_interp.ml b/compiler/plugins/lazy_interp.ml index 64f10101..da114e55 100644 --- a/compiler/plugins/lazy_interp.ml +++ b/compiler/plugins/lazy_interp.ml @@ -258,10 +258,10 @@ let interpret_program (prg : ('dcalc, 'm) gexpr program) (scope : ScopeName.t) : (* -- Plugin registration -- *) let run link_modules optimize check_invariants ex_scope options = - Interpreter.load_runtime_modules link_modules; let prg, ctx, _ = Driver.Passes.dcalc options ~link_modules ~optimize ~check_invariants in + Interpreter.load_runtime_modules prg; let scope = Driver.Commands.get_scope_uid ctx ex_scope in let result_expr, _env = interpret_program prg scope in let fmt = Format.std_formatter in diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index 8deac5bb..a37f7e13 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -940,17 +940,26 @@ let interpret_program_dcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list reflect that. *) let evaluate_expr ctx lang e = delcustom (evaluate_expr ctx lang (addcustom e)) -let load_runtime_modules = function +let load_runtime_modules prg = + match ModuleName.Map.keys prg.decl_ctx.ctx_modules with | [] -> () | modules -> Message.emit_debug "Loading shared modules..."; List.iter - Dynlink.( - fun m -> - try loadfile (adapt_filename File.(match Cli.globals.build_dir with None -> m -.- "cmo" | Some d -> d / m -.- "cmo")) - with Dynlink.Error dl_err -> - Message.raise_error - "Could not load module %s, has it been suitably compiled?@;\ - <1 2>@[%a@]" m Format.pp_print_text - (Dynlink.error_message dl_err)) + (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)) modules diff --git a/compiler/shared_ast/interpreter.mli b/compiler/shared_ast/interpreter.mli index 639a3edb..3f9c934a 100644 --- a/compiler/shared_ast/interpreter.mli +++ b/compiler/shared_ast/interpreter.mli @@ -72,6 +72,6 @@ val interpret_program_lcalc : providing for each argument a thunked empty default. Returns a list of all the computed values for the scope variables of the executed scope. *) -val load_runtime_modules : string list -> unit -(** Dynlink the given runtime modules, in order to make them callable by the - interpreter. If Cli.globals.build_dir is specified, the runtime module names are assumed to be relative and looked up there. *) +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. *) diff --git a/tests/test_modules/good/mod_use.catala_en b/tests/test_modules/good/mod_use.catala_en index 38dcc57f..53ce372e 100644 --- a/tests/test_modules/good/mod_use.catala_en +++ b/tests/test_modules/good/mod_use.catala_en @@ -22,10 +22,8 @@ scope T2: assertion o4 = 5.0 ``` -The following test is disabled at the moment because it requires prior compilation of the module. This will be fixed with the new Clerk version that handles dependencies transparently. - -```disabled catala-test-inline -$ catala interpret -s T2 --disable_warnings --use mod_def.catala_en +```catala-test-inline +$ catala interpret -s T2 [RESULT] Computation successful! Results: [RESULT] o1 = No () [RESULT] o2 = Maybe ()