CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-19 00:15:39 +03:00
Code Issues Projects Releases Wiki Activity

Improve handling of module name definitions

Browse Source 
and add some sanity-checks for consistency of used modules w.r.t. actually
loaded modules.
This commit is contained in:
Louis Gesbert 2023-09-19 11:44:18 +02:00
parent 22c69938b6
commit f162f6e9bd
25 changed files with 205 additions and 128 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
compiler/dcalc/from_scopelang.ml
View File

@ -1257,5 +1257,6 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
{
code_items = Bindlib.unbox items;
decl_ctx = ctx.decl_ctx;
module_name = prgm.Scopelang.Ast.program_module_name;
lang = prgm.program_lang;
}

1
compiler/desugared/ast.ml
View File

@ -229,6 +229,7 @@ type scope = {
}
type program = {
program_module_name : ModuleName.t option;
program_scopes : scope ScopeName.Map.t;
program_topdefs : (expr option * typ) TopdefName.Map.t;
program_ctx : decl_ctx;

1
compiler/desugared/ast.mli
View File

@ -113,6 +113,7 @@ type scope = {
}
type program = {
program_module_name : ModuleName.t option;
program_scopes : scope ScopeName.Map.t;
program_topdefs : (expr option * typ) TopdefName.Map.t;
program_ctx : decl_ctx;

6
compiler/desugared/from_surface.ml
View File

@ -1469,6 +1469,8 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) :
in
{
Ast.program_lang = surface.program_lang;
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
@ -1524,8 +1526,8 @@ 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 _ -> prgm
| S.ModuleDef _ | S.ModuleUse _ -> prgm
| S.LawInclude _ | S.LawText _
| S.ModuleUse _ | S.ModuleDef _ -> prgm
in
let desugared =
List.fold_left

2
compiler/desugared/linting.ml
View File

@ -103,6 +103,7 @@ 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 ->
@ -167,6 +168,7 @@ let detect_unused_struct_fields (p : program) : unit =
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 ->

78
compiler/driver.ml
View File

@ -42,16 +42,60 @@ let get_lang options file =
@{<yellow>%s@}, and @{<bold>--language@} was not specified"
filename)
let load_module_interfaces options link_modules =
List.map
(fun f ->
let lang = get_lang options (FileName f) in
let modname, intf =
Surface.Parser_driver.load_interface (FileName f) lang
in
(* maybe warn here if [modname_of_file f <> modname] ? *)
modname, intf)
link_modules
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
in
let load_file f =
let lang = get_lang options (FileName f) in
let (mname, intf), using =
Surface.Parser_driver.load_interface (FileName f) lang
in
(ModuleName.of_string mname, intf), using
in
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) ->
if MS.mem modname required then
let required =
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
in
if List.length remaining < List.length interfaces then
(* Loop until fixpoint *)
check (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
Message.raise_multispanned_error
(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)
unused)
"Modules used from the program don't match the command-line";
loaded
module Passes = struct
(* Each pass takes only its cli options, then calls upon its dependent passes
@ -68,10 +112,8 @@ module Passes = struct
Surface.Parser_driver.parse_top_level_file options.input_file language
in
let prg = Surface.Fill_positions.fill_pos_with_legislative_info prg in
let prg =
{ prg with program_modules = load_module_interfaces options link_modules }
in
prg, language
let program_modules = load_module_interfaces options prg link_modules in
{ prg with program_modules }, language
let desugared options ~link_modules :
Desugared.Ast.program * Desugared.Name_resolution.context =
@ -695,13 +737,7 @@ module Commands = struct
Message.emit_debug "Compiling program into OCaml...";
Message.emit_debug "Writing to %s..."
(Option.value ~default:"stdout" output_file);
let modname =
(* TODO: module directive *)
match options.Cli.input_file with
| FileName n -> Some (modname_of_file n)
| _ -> None
in
Lcalc.To_ocaml.format_program fmt ?register_module:modname prg type_ordering
Lcalc.To_ocaml.format_program fmt prg type_ordering
let ocaml_cmd =
Cmd.v

4
compiler/lcalc/closure_conversion.ml
View File

@ -356,7 +356,9 @@ 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; lang = p.lang })
{ code_items = new_code_items; decl_ctx = new_decl_ctx;
module_name = p.module_name;
lang = p.lang; })
new_code_items
(** {1 Hoisting closures}*)

2
compiler/lcalc/compile_without_exceptions.ml
View File

@ -769,4 +769,4 @@ let translate_program (prgm : typed D.program) : untyped A.program =
(* program is closed here. *)
let code_items = Bindlib.unbox code_items in
Program.untype { decl_ctx; code_items; lang = prgm.lang }
Program.untype { prgm with decl_ctx; code_items }

8
compiler/lcalc/to_ocaml.ml
View File

@ -647,7 +647,7 @@ 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 %S" 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 "[ ";
@ -664,7 +664,8 @@ let format_module_registration
Format.pp_print_space fmt ();
Format.pp_print_string fmt "\"todo-module-hash\"";
Format.pp_close_box fmt ();
Format.pp_close_box fmt ()
Format.pp_close_box fmt ();
Format.pp_print_newline fmt ()
let header =
{ocaml|
@ -678,7 +679,6 @@ open Runtime_ocaml.Runtime
let format_program
(fmt : Format.formatter)
?register_module
?exec_scope
(p : 'm Ast.program)
(type_ordering : Scopelang.Dependency.TVertex.t list) : unit =
@ -686,7 +686,7 @@ let format_program
format_ctx type_ordering fmt p.decl_ctx;
let bnd = format_code_items p.decl_ctx fmt p.code_items in
Format.pp_print_newline fmt ();
match register_module, exec_scope with
match p.module_name, exec_scope with
| Some modname, None -> format_module_registration fmt bnd modname
| None, Some scope_name ->
let scope_body = Program.get_scope_body p scope_name in

3
compiler/lcalc/to_ocaml.mli
View File

@ -38,7 +38,6 @@ val format_var : Format.formatter -> 'm Var.t -> unit
val format_program :
Format.formatter ->
?register_module:string ->
?exec_scope:ScopeName.t ->
'm Ast.program ->
Scopelang.Dependency.TVertex.t list ->
@ -46,7 +45,5 @@ val format_program :
(** Usage [format_program fmt p type_dependencies_ordering]. Either one of these
may be set:
- [register_module] will register the module for dynamic loading under the
given name
- [exec_scope] will mark the named scope as "main" and execute it at the end
of the program. It must have no inputs. *)

2
compiler/plugins/api_web.ml
View File

@ -457,7 +457,7 @@ let run
Message.emit_debug "Compiling program into OCaml...";
Message.emit_debug "Writing to %s..."
(Option.value ~default:"stdout" output_file);
Lcalc.To_ocaml.format_program fmt ?register_module:modname prg type_ordering
Lcalc.To_ocaml.format_program fmt prg type_ordering
in
let jsoo_output_file, with_formatter =
Driver.Commands.get_output_format options ~ext:"_api_web.ml" output

8
compiler/plugins/modules.ml
View File

@ -40,7 +40,7 @@ let action_flag =
silent. Assertions will be checked, though." );
]
let gen_ocaml options link_modules optimize check_invariants modname main =
let gen_ocaml options link_modules optimize check_invariants main =
let prg, ctx, type_ordering =
Driver.Passes.lcalc options ~link_modules ~optimize ~check_invariants
~avoid_exceptions:false ~closure_conversion:false
@ -51,7 +51,7 @@ let gen_ocaml options link_modules optimize check_invariants modname main =
in
with_output
@@ fun ppf ->
Lcalc.To_ocaml.format_program ppf ?register_module:modname ?exec_scope prg
Lcalc.To_ocaml.format_program ppf ?exec_scope prg
type_ordering;
Option.get filename
@ -131,7 +131,7 @@ let compile options link_modules optimize check_invariants =
in
let basename = String.uncapitalize_ascii modname in
let ml_file =
gen_ocaml options link_modules optimize check_invariants (Some modname) None
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
@ -148,7 +148,7 @@ let compile options link_modules optimize check_invariants =
let link options link_modules optimize check_invariants output ex_scope_opt =
let ml_file =
gen_ocaml options link_modules optimize check_invariants None ex_scope_opt
gen_ocaml options link_modules optimize check_invariants ex_scope_opt
in
(* NOTE: assuming native target at the moment *)
let cmd = "ocamlopt" in

1
compiler/scopelang/ast.ml
View File

@ -51,6 +51,7 @@ type 'm scope_decl = {
}
type 'm program = {
program_module_name : ModuleName.t option;
program_scopes : 'm scope_decl Mark.pos ScopeName.Map.t;
program_topdefs : ('m expr * typ) TopdefName.Map.t;
program_modules : nil program ModuleName.Map.t;

1
compiler/scopelang/ast.mli
View File

@ -44,6 +44,7 @@ type 'm scope_decl = {
}
type 'm program = {
program_module_name : ModuleName.t option;
program_scopes : 'm scope_decl Mark.pos ScopeName.Map.t;
program_topdefs : ('m expr * typ) TopdefName.Map.t;
program_modules : nil program ModuleName.Map.t;

2
compiler/scopelang/from_desugared.ml
View File

@ -821,6 +821,7 @@ let translate_program
(fun modname m_desugared ->
let ctx = ModuleName.Map.find modname ctx.modules in
{
Ast.program_module_name = Some modname;
Ast.program_topdefs = TopdefName.Map.empty;
program_scopes =
ScopeName.Map.map
@ -852,6 +853,7 @@ let translate_program
desugared.D.program_scopes
in
{
Ast.program_module_name = desugared.D.program_module_name;
Ast.program_topdefs;
Ast.program_scopes;
Ast.program_ctx;

1
compiler/shared_ast/definitions.ml
View File

@ -670,4 +670,5 @@ type 'e program = {
decl_ctx : decl_ctx;
code_items : 'e code_item_list;
lang : Cli.backend_lang;
module_name : ModuleName.t option;
}

4
compiler/shared_ast/interpreter.ml
View File

@ -944,7 +944,9 @@ let load_runtime_modules prg =
match ModuleName.Map.keys prg.decl_ctx.ctx_modules with
| [] -> ()
| modules ->
Message.emit_debug "Loading shared modules...";
Message.emit_debug "Loading shared modules... %a"
(fun ppf -> ModuleName.Map.format_keys ppf)
prg.decl_ctx.ctx_modules;
List.iter
(fun m ->
let srcfile = Pos.get_file (ModuleName.pos m) in

4
compiler/shared_ast/program.ml
View File

@ -17,9 +17,9 @@
open Definitions
let map_exprs ~f ~varf { code_items; decl_ctx; lang } =
let map_exprs ~f ~varf { code_items; decl_ctx; lang; module_name } =
Bindlib.box_apply
(fun code_items -> { code_items; decl_ctx; lang })
(fun code_items -> { code_items; decl_ctx; lang; module_name })
(Scope.map_exprs ~f ~varf code_items)
let fold_left_exprs ~f ~init { code_items; _ } =

1
compiler/shared_ast/typing.ml
View File

@ -1042,6 +1042,7 @@ let program ~leave_unresolved prg =
in
{
A.lang = prg.lang;
A.module_name = prg.A.module_name;
A.code_items = Bindlib.unbox code_items;
decl_ctx =
{

2
compiler/surface/ast.ml
View File

@ -317,9 +317,11 @@ and interface = uident Mark.pos * code_block
elements with [topdef_expr = None] *)
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_lang : Cli.backend_lang; [@opaque]
}

180
compiler/surface/parser_driver.ml
View File

@ -251,9 +251,10 @@ let rec parse_source_file
(match input with Some input -> close_in input | None -> ());
let program = expand_includes source_file_name commands language in
{
program_module_name = program.Ast.program_module_name;
program_items = program.Ast.program_items;
program_source_files = source_file_name :: program.Ast.program_source_files;
program_modules = [];
program_modules = program.program_modules;
program_lang = language;
}
@ -263,95 +264,124 @@ and expand_includes
(source_file : string)
(commands : Ast.law_structure list)
(language : Cli.backend_lang) : Ast.program =
List.fold_left
(fun acc command ->
match command with
| Ast.LawInclude (Ast.CatalaFile sub_source) ->
let source_dir = Filename.dirname source_file in
let sub_source = File.(source_dir / Mark.remove sub_source) in
let includ_program = parse_source_file (FileName sub_source) language in
{
Ast.program_source_files =
acc.Ast.program_source_files @ includ_program.program_source_files;
Ast.program_items =
acc.Ast.program_items @ includ_program.program_items;
Ast.program_modules =
acc.Ast.program_modules @ includ_program.program_modules;
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 '@{<yellow>> Include@}' directive. You should use it as a module with '@{<yellow>> 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_items = commands';
Ast.program_source_files = new_sources;
Ast.program_modules = new_modules;
}
| 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_source_files = acc.Ast.program_source_files @ new_sources;
Ast.program_items =
acc.Ast.program_items @ [Ast.LawHeading (heading, commands')];
Ast.program_modules = acc.Ast.program_modules @ new_modules;
} =
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 = acc.Ast.program_items @ [i] })
{
Ast.program_source_files = [];
Ast.program_items = [];
Ast.program_modules = [];
Ast.program_lang = language;
}
commands
}
| i -> { acc with Ast.program_items = i :: acc.Ast.program_items })
{
Ast.program_module_name = None;
Ast.program_source_files = [];
Ast.program_items = [];
Ast.program_modules = [];
Ast.program_lang = language;
}
commands
in
{
Ast.program_lang = language;
Ast.program_module_name = rprg.Ast.program_module_name;
Ast.program_source_files = List.rev rprg.Ast.program_source_files;
Ast.program_items = List.rev rprg.Ast.program_items;
Ast.program_modules = List.rev rprg.Ast.program_modules;
}
(** {2 Handling interfaces} *)
let get_interface program =
let rec filter (modname, acc) = function
| Ast.LawInclude _ | Ast.LawText _ | Ast.ModuleUse _ -> modname, acc
| Ast.ModuleDef ((_, pos2) as mdef) -> (
match modname with
| None -> Some mdef, acc
| Some (_, pos1) ->
Message.raise_multispanned_error
[None, pos1; None, pos2]
"Multiple definitions of the module name")
| Ast.LawHeading (_, str) -> List.fold_left filter (modname, acc) str
let rec filter (req, acc) = function
| 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.CodeBlock (code, _, true) ->
let acc =
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
in
modname, acc
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 *)
modname, acc
req, acc
in
List.fold_left filter (None, []) program.Ast.program_items
List.fold_left filter ([], []) program.Ast.program_items
(** {1 API} *)
let load_interface source_file language =
let modname, intf = parse_source_file source_file language |> get_interface in
match modname with
| Some m -> m, intf
| None ->
Message.raise_error
"%s doesn't define a module name. It should contain a '@{<cyan>> Module \
%s@}' directive."
(match source_file with
| FileName s -> "File " ^ s
| Contents _ -> "Source input")
(match source_file with
| FileName s ->
String.capitalize_ascii Filename.(basename (remove_extension s))
| Contents _ -> "Module_name")
let program = parse_source_file source_file language in
let modname =
match program.Ast.program_module_name with
| Some mname -> mname
| None ->
Message.raise_error
"%s doesn't define a module name. It should contain a '@{<cyan>> Module \
%s@}' directive."
(match source_file with
| FileName s -> "File " ^ s
| Contents _ -> "Source input")
(match source_file with
| 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
let parse_top_level_file
(source_file : Cli.input_file)

7
compiler/surface/parser_driver.mli
View File

@ -23,10 +23,9 @@ val lines : File.t -> Cli.backend_lang -> (string * Lexer_common.line_token) Seq
(** 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
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 declared module name as well *)
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. Modules
in the program 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. *)

5
tests/test_modules/good/output/mod_def.ml
View File

@ -50,3 +50,8 @@ let s (s_in: S_in.t) : S.t =
let half_ : integer -> decimal =
fun (x_: integer) -> o_div_int_int x_ (integer_of_string "2")
let () =
Runtime_ocaml.Runtime.register_module "Mod_def"
[ "S", Obj.repr s;
"half", Obj.repr half_ ]
"todo-module-hash"

4
tests/test_name_resolution/good/let_in2.catala_en
View File

@ -66,8 +66,4 @@ let s (s_in: S_in.t) : S.t =
start_line=5; start_column=18; end_line=5; end_column=19;
law_headings=["Article"]})) in
{S.a = a_}
let () =
Runtime_ocaml.Runtime.register_module "Let_in2"
[ "S", Obj.repr s ]
"todo-module-hash"
```

5
tests/test_scope/good/191_fix_record_name_confusion.catala_en
View File

@ -60,9 +60,4 @@ let scope_b (scope_b_in: ScopeB_in.t) : ScopeB.t =
start_line=8; start_column=10; end_line=8; end_column=11;
law_headings=["Article"]})) in
{ScopeB.a = a_}
let () =
Runtime_ocaml.Runtime.register_module "191_fix_record_name_confusion"
[ "ScopeA", Obj.repr scope_a;
"ScopeB", Obj.repr scope_b ]
"todo-module-hash"
```