mirror of
https://github.com/CatalaLang/catala.git
synced 2024-09-19 00:15:39 +03:00
Reformat
This commit is contained in:
parent
8df49dcea2
commit
1ae955b504
@ -729,8 +729,8 @@ let gen_build_statements
|
||||
~outputs:[inc (srcv ^ "@test")]
|
||||
~inputs:[srcv; inc (srcv ^ "@out")]
|
||||
~implicit_in:
|
||||
("always" ::
|
||||
List.map
|
||||
("always"
|
||||
:: List.map
|
||||
(fun test -> legacy_test_reference test ^ "@post")
|
||||
item.legacy_tests);
|
||||
results;
|
||||
|
@ -88,10 +88,11 @@ module Make (Ord : OrderedType) : S with type key = Ord.t = struct
|
||||
let keys t = fold (fun k _ acc -> k :: acc) t [] |> List.rev
|
||||
let values t = fold (fun _ v acc -> v :: acc) t [] |> List.rev
|
||||
let of_list l = List.fold_left (fun m (k, v) -> add k v m) empty l
|
||||
|
||||
let disjoint_union t1 t2 =
|
||||
union (fun k _ _ ->
|
||||
Format.kasprintf failwith
|
||||
"Maps are not disjoint: conflict on key %a"
|
||||
union
|
||||
(fun k _ _ ->
|
||||
Format.kasprintf failwith "Maps are not disjoint: conflict on key %a"
|
||||
Ord.format k)
|
||||
t1 t2
|
||||
|
||||
|
@ -68,7 +68,6 @@ module Make (X : Info) (S : Style) () : Id with type info = X.info = struct
|
||||
|
||||
let get_info (uid : t) : X.info = uid.info
|
||||
let hash (x : t) : int = x.id
|
||||
|
||||
let to_string t = X.to_string t.info
|
||||
|
||||
module Set = Set.Make (Ordering)
|
||||
|
@ -509,7 +509,9 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
|
||||
|> SubScopeName.Map.find (Mark.remove alias)
|
||||
|> retrieve_in_and_out_typ_or_any var
|
||||
| ELocation (ToplevelVar { name }) -> (
|
||||
let typ = TopdefName.Map.find (Mark.remove name) ctx.decl_ctx.ctx_topdefs in
|
||||
let typ =
|
||||
TopdefName.Map.find (Mark.remove name) ctx.decl_ctx.ctx_topdefs
|
||||
in
|
||||
match Mark.remove typ with
|
||||
| TArrow (tin, (tout, _)) -> List.map Mark.remove tin, tout
|
||||
| _ ->
|
||||
@ -720,9 +722,7 @@ let translate_rule
|
||||
didn't seem worth it *)
|
||||
| Call (subname, subindex, m) ->
|
||||
let subscope_sig = ScopeName.Map.find subname ctx.scopes_parameters in
|
||||
let scope_sig_decl =
|
||||
ScopeName.Map.find subname ctx.decl_ctx.ctx_scopes
|
||||
in
|
||||
let scope_sig_decl = ScopeName.Map.find subname ctx.decl_ctx.ctx_scopes in
|
||||
let all_subscope_vars = subscope_sig.scope_sig_local_vars in
|
||||
let all_subscope_input_vars =
|
||||
List.filter
|
||||
@ -1082,9 +1082,7 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
|
||||
External_scope_ref
|
||||
(Mark.copy (ScopeName.get_info scope_name) scope_name)
|
||||
in
|
||||
let scope_info =
|
||||
ScopeName.Map.find scope_name decl_ctx.ctx_scopes
|
||||
in
|
||||
let scope_info = ScopeName.Map.find scope_name decl_ctx.ctx_scopes in
|
||||
let scope_sig_in_fields =
|
||||
(* Output fields have already been generated and added to the program
|
||||
ctx at this point, because they are visible to the user (manipulated
|
||||
@ -1137,9 +1135,8 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
|
||||
process_scope_sig decl_ctx scope_name scope_decl)
|
||||
scopes
|
||||
in
|
||||
ModuleName.Map.fold (fun _ s ->
|
||||
ScopeName.Map.disjoint_union
|
||||
(process_scopes s))
|
||||
ModuleName.Map.fold
|
||||
(fun _ s -> ScopeName.Map.disjoint_union (process_scopes s))
|
||||
prgm.Scopelang.Ast.program_modules
|
||||
(process_scopes prgm.Scopelang.Ast.program_scopes)
|
||||
in
|
||||
|
@ -123,7 +123,8 @@ type modul = {
|
||||
type program = {
|
||||
program_module_name : Ident.t Mark.pos option;
|
||||
program_ctx : decl_ctx;
|
||||
program_modules : modul ModuleName.Map.t; (** Contains all submodules of the program, in a flattened structure *)
|
||||
program_modules : modul ModuleName.Map.t;
|
||||
(** Contains all submodules of the program, in a flattened structure *)
|
||||
program_root : modul;
|
||||
program_lang : Cli.backend_lang;
|
||||
}
|
||||
|
@ -76,7 +76,8 @@ let program prg =
|
||||
let modul =
|
||||
List.fold_left
|
||||
(fun _ m -> ModuleName.Map.find m prg.program_modules)
|
||||
prg.program_root (ScopeName.path scope_name)
|
||||
prg.program_root
|
||||
(ScopeName.path scope_name)
|
||||
in
|
||||
let scope = ScopeName.Map.find scope_name modul.module_scopes in
|
||||
let vars =
|
||||
@ -88,8 +89,8 @@ let program prg =
|
||||
scope.scope_defs ScopeVar.Map.empty
|
||||
in
|
||||
(* at this stage, rule resolution and the corresponding encapsulation
|
||||
into default terms hasn't taken place, so input and output
|
||||
variables don't need different typing *)
|
||||
into default terms hasn't taken place, so input and output variables
|
||||
don't need different typing *)
|
||||
Typing.Env.add_scope scope_name ~vars ~in_vars:vars env)
|
||||
prg.program_ctx.ctx_scopes env
|
||||
in
|
||||
@ -102,7 +103,6 @@ let program prg =
|
||||
prg.program_root.module_topdefs
|
||||
in
|
||||
let module_scopes =
|
||||
ScopeName.Map.map (scope prg.program_ctx env)
|
||||
prg.program_root.module_scopes
|
||||
ScopeName.Map.map (scope prg.program_ctx env) prg.program_root.module_scopes
|
||||
in
|
||||
{ prg with program_root = { module_topdefs; module_scopes } }
|
||||
|
@ -509,7 +509,8 @@ let rec translate_expr
|
||||
Expr.estruct ~name:s_uid ~fields:s_fields emark
|
||||
| EnumInject (((path, (constructor, pos_constructor)), _), payload) -> (
|
||||
let get_possible_c_uids ctxt =
|
||||
try Ident.Map.find constructor ctxt.Name_resolution.local.constructor_idmap
|
||||
try
|
||||
Ident.Map.find constructor ctxt.Name_resolution.local.constructor_idmap
|
||||
with Ident.Map.Not_found _ ->
|
||||
raise_error_cons_not_found ctxt (constructor, pos_constructor)
|
||||
in
|
||||
@ -1018,7 +1019,9 @@ let process_def
|
||||
(ctxt : Name_resolution.context)
|
||||
(prgm : Ast.program)
|
||||
(def : S.definition) : Ast.program =
|
||||
let scope : Ast.scope = ScopeName.Map.find scope_uid prgm.program_root.module_scopes in
|
||||
let scope : Ast.scope =
|
||||
ScopeName.Map.find scope_uid prgm.program_root.module_scopes
|
||||
in
|
||||
let scope_ctxt = ScopeName.Map.find scope_uid ctxt.scopes in
|
||||
let def_key =
|
||||
Name_resolution.get_def_key
|
||||
@ -1083,13 +1086,9 @@ let process_def
|
||||
}
|
||||
in
|
||||
let module_scopes =
|
||||
ScopeName.Map.add scope_uid scope_updated
|
||||
prgm.program_root.module_scopes
|
||||
ScopeName.Map.add scope_uid scope_updated prgm.program_root.module_scopes
|
||||
in
|
||||
{
|
||||
prgm with
|
||||
program_root = { prgm.program_root with module_scopes }
|
||||
}
|
||||
{ prgm with program_root = { prgm.program_root with module_scopes } }
|
||||
|
||||
(** Translates a {!type: S.rule} from the surface language *)
|
||||
let process_rule
|
||||
@ -1108,7 +1107,9 @@ let process_assert
|
||||
(ctxt : Name_resolution.context)
|
||||
(prgm : Ast.program)
|
||||
(ass : S.assertion) : Ast.program =
|
||||
let scope : Ast.scope = ScopeName.Map.find scope_uid prgm.program_root.module_scopes in
|
||||
let scope : Ast.scope =
|
||||
ScopeName.Map.find scope_uid prgm.program_root.module_scopes
|
||||
in
|
||||
let ass =
|
||||
translate_expr (Some scope_uid) None ctxt Ident.Map.empty
|
||||
(match ass.S.assertion_condition with
|
||||
@ -1140,12 +1141,10 @@ let process_assert
|
||||
scope.scope_assertions;
|
||||
}
|
||||
in
|
||||
let module_scopes = ScopeName.Map.add scope_uid new_scope prgm.program_root.module_scopes
|
||||
let module_scopes =
|
||||
ScopeName.Map.add scope_uid new_scope prgm.program_root.module_scopes
|
||||
in
|
||||
{
|
||||
prgm with
|
||||
program_root = { prgm.program_root with module_scopes }
|
||||
}
|
||||
{ prgm with program_root = { prgm.program_root with module_scopes } }
|
||||
|
||||
(** Translates a surface definition, rule or assertion *)
|
||||
let process_scope_use_item
|
||||
@ -1163,7 +1162,9 @@ let process_scope_use_item
|
||||
| S.Assertion ass -> process_assert precond scope ctxt prgm ass
|
||||
| S.DateRounding (r, _) ->
|
||||
let scope_uid = scope in
|
||||
let scope : Ast.scope = ScopeName.Map.find scope_uid prgm.program_root.module_scopes in
|
||||
let scope : Ast.scope =
|
||||
ScopeName.Map.find scope_uid prgm.program_root.module_scopes
|
||||
in
|
||||
let r =
|
||||
match r with
|
||||
| S.Increasing -> Ast.Increasing
|
||||
@ -1188,11 +1189,10 @@ let process_scope_use_item
|
||||
Mark.copy item (Ast.DateRounding r) :: scope.scope_options;
|
||||
}
|
||||
in
|
||||
let module_scopes = ScopeName.Map.add scope_uid new_scope prgm.program_root.module_scopes in
|
||||
{
|
||||
prgm with
|
||||
program_root = { prgm.program_root with module_scopes }
|
||||
}
|
||||
let module_scopes =
|
||||
ScopeName.Map.add scope_uid new_scope prgm.program_root.module_scopes
|
||||
in
|
||||
{ prgm with program_root = { prgm.program_root with module_scopes } }
|
||||
| _ -> prgm
|
||||
|
||||
(** {1 Translating top-level items} *)
|
||||
@ -1267,7 +1267,9 @@ let process_topdef
|
||||
(prgm : Ast.program)
|
||||
(def : S.top_def) : Ast.program =
|
||||
let id =
|
||||
Ident.Map.find (Mark.remove def.S.topdef_name) ctxt.Name_resolution.local.topdefs
|
||||
Ident.Map.find
|
||||
(Mark.remove def.S.topdef_name)
|
||||
ctxt.Name_resolution.local.topdefs
|
||||
in
|
||||
let translate_typ t = Name_resolution.process_type ctxt t in
|
||||
let translate_tbase (tbase, m) = translate_typ (Base tbase, m) in
|
||||
@ -1391,7 +1393,10 @@ let init_scope_defs
|
||||
let ctxt =
|
||||
List.fold_left
|
||||
(fun ctx m ->
|
||||
{ ctxt with local = ModuleName.Map.find m ctx.Name_resolution.modules })
|
||||
{
|
||||
ctxt with
|
||||
local = ModuleName.Map.find m ctx.Name_resolution.modules;
|
||||
})
|
||||
ctxt
|
||||
(ScopeName.path subscope_uid)
|
||||
in
|
||||
@ -1430,9 +1435,7 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) :
|
||||
match v with
|
||||
| SubScope _ -> acc
|
||||
| ScopeVar v -> (
|
||||
let v_sig =
|
||||
ScopeVar.Map.find v ctxt.Name_resolution.var_typs
|
||||
in
|
||||
let v_sig = ScopeVar.Map.find v ctxt.Name_resolution.var_typs in
|
||||
match v_sig.Name_resolution.var_sig_states_list with
|
||||
| [] -> ScopeVar.Map.add v Ast.WholeVar acc
|
||||
| states -> ScopeVar.Map.add v (Ast.States states) acc))
|
||||
@ -1458,39 +1461,45 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) :
|
||||
}
|
||||
in
|
||||
let get_scopes mctx =
|
||||
Ident.Map.fold (fun _ tydef acc -> match tydef with
|
||||
Ident.Map.fold
|
||||
(fun _ tydef acc ->
|
||||
match tydef with
|
||||
| Name_resolution.TScope (s_uid, _) ->
|
||||
ScopeName.Map.add s_uid (get_scope s_uid) acc
|
||||
| _ -> acc)
|
||||
mctx.Name_resolution.typedefs ScopeName.Map.empty;
|
||||
mctx.Name_resolution.typedefs ScopeName.Map.empty
|
||||
in
|
||||
let program_modules =
|
||||
ModuleName.Map.map (fun mctx ->
|
||||
{ Ast.module_scopes = get_scopes mctx;
|
||||
ModuleName.Map.map
|
||||
(fun mctx ->
|
||||
{
|
||||
Ast.module_scopes = get_scopes mctx;
|
||||
Ast.module_topdefs =
|
||||
Ident.Map.fold (fun _ name acc ->
|
||||
Ident.Map.fold
|
||||
(fun _ name acc ->
|
||||
TopdefName.Map.add name
|
||||
(None,
|
||||
TopdefName.Map.find name ctxt.Name_resolution.topdef_types)
|
||||
acc;
|
||||
( None,
|
||||
TopdefName.Map.find name ctxt.Name_resolution.topdef_types
|
||||
)
|
||||
mctx.topdefs TopdefName.Map.empty
|
||||
acc)
|
||||
mctx.topdefs TopdefName.Map.empty;
|
||||
})
|
||||
ctxt.modules
|
||||
in
|
||||
let program_ctx =
|
||||
let open Name_resolution in
|
||||
let ctx_scopes mctx acc =
|
||||
Ident.Map.fold (fun _ tydef acc ->
|
||||
Ident.Map.fold
|
||||
(fun _ tydef acc ->
|
||||
match tydef with
|
||||
| TScope (s_uid, info) ->
|
||||
ScopeName.Map.add s_uid info acc
|
||||
| TScope (s_uid, info) -> ScopeName.Map.add s_uid info acc
|
||||
| _ -> acc)
|
||||
mctx.Name_resolution.typedefs acc
|
||||
in
|
||||
let ctx_modules =
|
||||
let rec aux mctx =
|
||||
Ident.Map.fold (fun _ m (M acc) ->
|
||||
Ident.Map.fold
|
||||
(fun _ m (M acc) ->
|
||||
let sub = aux (ModuleName.Map.find m ctxt.modules) in
|
||||
M (ModuleName.Map.add m sub acc))
|
||||
mctx.used_modules (M ModuleName.Map.empty)
|
||||
@ -1501,14 +1510,16 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) :
|
||||
ctx_structs = ctxt.structs;
|
||||
ctx_enums = ctxt.enums;
|
||||
ctx_scopes =
|
||||
ModuleName.Map.fold (fun _ -> ctx_scopes)
|
||||
ModuleName.Map.fold
|
||||
(fun _ -> ctx_scopes)
|
||||
ctxt.modules
|
||||
(ctx_scopes ctxt.local ScopeName.Map.empty);
|
||||
ctx_topdefs = ctxt.topdef_types;
|
||||
ctx_struct_fields = ctxt.local.field_idmap;
|
||||
ctx_enum_constrs = ctxt.local.constructor_idmap;
|
||||
ctx_scope_index =
|
||||
Ident.Map.filter_map (fun _ -> function
|
||||
Ident.Map.filter_map
|
||||
(fun _ -> function
|
||||
| Name_resolution.TScope (s, _) -> Some s
|
||||
| _ -> None)
|
||||
ctxt.local.typedefs;
|
||||
@ -1521,7 +1532,8 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) :
|
||||
Ast.program_module_name = surface.Surface.Ast.program_module_name;
|
||||
Ast.program_modules;
|
||||
Ast.program_ctx;
|
||||
Ast.program_root = {
|
||||
Ast.program_root =
|
||||
{
|
||||
Ast.module_scopes = get_scopes ctxt.Name_resolution.local;
|
||||
Ast.module_topdefs = TopdefName.Map.empty;
|
||||
};
|
||||
|
@ -257,8 +257,7 @@ let get_module_ctx ctxt id =
|
||||
let rec module_ctx ctxt path0 =
|
||||
match path0 with
|
||||
| [] -> ctxt
|
||||
| mod_id :: path ->
|
||||
module_ctx (get_module_ctx ctxt mod_id) path
|
||||
| mod_id :: path -> module_ctx (get_module_ctx ctxt mod_id) path
|
||||
|
||||
(** {1 Declarations pass} *)
|
||||
|
||||
@ -343,7 +342,8 @@ let rec process_base_typ
|
||||
"This refers to module @{<blue>%s@}, which was not found" modul
|
||||
| Some mname ->
|
||||
let mod_ctxt = ModuleName.Map.find mname ctxt.modules in
|
||||
process_base_typ { ctxt with local = mod_ctxt }
|
||||
process_base_typ
|
||||
{ ctxt with local = mod_ctxt }
|
||||
Surface.Ast.(Data (Primitive (Named (path, id))), typ_pos)))
|
||||
|
||||
(** Process a type (function or not) *)
|
||||
@ -602,7 +602,8 @@ let process_scope_decl (ctxt : context) (decl : Surface.Ast.scope_decl) :
|
||||
| ScopeVar v -> (
|
||||
try
|
||||
let field =
|
||||
StructName.Map.find str (Ident.Map.find id ctxt.local.field_idmap)
|
||||
StructName.Map.find str
|
||||
(Ident.Map.find id ctxt.local.field_idmap)
|
||||
in
|
||||
ScopeVar.Map.add v field svmap
|
||||
with StructName.Map.Not_found _ | Ident.Map.Not_found _ -> svmap))
|
||||
@ -669,11 +670,7 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
|
||||
}
|
||||
ctxt.scopes
|
||||
in
|
||||
{
|
||||
ctxt with
|
||||
local = { ctxt.local with typedefs };
|
||||
scopes;
|
||||
}
|
||||
{ ctxt with local = { ctxt.local with typedefs }; scopes }
|
||||
| StructDecl sdecl ->
|
||||
let name, pos = sdecl.struct_decl_name in
|
||||
Option.iter
|
||||
@ -684,9 +681,9 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
|
||||
let typedefs =
|
||||
Ident.Map.add
|
||||
(Mark.remove sdecl.struct_decl_name)
|
||||
(TStruct s_uid) ctxt.local.typedefs;
|
||||
(TStruct s_uid) ctxt.local.typedefs
|
||||
in
|
||||
{ ctxt with local = { ctxt.local with typedefs} }
|
||||
{ ctxt with local = { ctxt.local with typedefs } }
|
||||
| EnumDecl edecl ->
|
||||
let name, pos = edecl.enum_decl_name in
|
||||
Option.iter
|
||||
@ -699,7 +696,7 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
|
||||
(Mark.remove edecl.enum_decl_name)
|
||||
(TEnum e_uid) ctxt.local.typedefs
|
||||
in
|
||||
{ ctxt with local = { ctxt.local with typedefs} }
|
||||
{ ctxt with local = { ctxt.local with typedefs } }
|
||||
| ScopeUse _ -> ctxt
|
||||
| Topdef def ->
|
||||
let name, pos = def.topdef_name in
|
||||
@ -940,16 +937,18 @@ let process_use_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
|
||||
|
||||
(** {1 API} *)
|
||||
|
||||
let empty_module_ctxt = {
|
||||
let empty_module_ctxt =
|
||||
{
|
||||
path = [];
|
||||
typedefs = Ident.Map.empty;
|
||||
field_idmap = Ident.Map.empty;
|
||||
constructor_idmap = Ident.Map.empty;
|
||||
topdefs = Ident.Map.empty;
|
||||
used_modules = Ident.Map.empty;
|
||||
}
|
||||
}
|
||||
|
||||
let empty_ctxt = {
|
||||
let empty_ctxt =
|
||||
{
|
||||
scopes = ScopeName.Map.empty;
|
||||
topdef_types = TopdefName.Map.empty;
|
||||
var_typs = ScopeVar.Map.empty;
|
||||
@ -957,31 +956,43 @@ let empty_ctxt = {
|
||||
enums = EnumName.Map.empty;
|
||||
modules = ModuleName.Map.empty;
|
||||
local = empty_module_ctxt;
|
||||
}
|
||||
}
|
||||
|
||||
(** Derive the context from metadata, in one pass over the declarations *)
|
||||
let form_context (surface, mod_uses) surface_modules : context =
|
||||
let rec process_modules ctxt mod_uses =
|
||||
(* Recursing on [mod_uses] rather than folding on [modules] ensures a topological traversal. *)
|
||||
Ident.Map.fold (fun _alias m ctxt ->
|
||||
(* Recursing on [mod_uses] rather than folding on [modules] ensures a
|
||||
topological traversal. *)
|
||||
Ident.Map.fold
|
||||
(fun _alias m ctxt ->
|
||||
match ModuleName.Map.find_opt m ctxt.modules with
|
||||
| Some _ -> ctxt
|
||||
| None ->
|
||||
let intf, mod_uses = ModuleName.Map.find m surface_modules in
|
||||
let ctxt = process_modules ctxt mod_uses in
|
||||
let ctxt = { ctxt with
|
||||
local = { ctxt.local with used_modules = mod_uses;
|
||||
path = [m] } } in
|
||||
let ctxt = List.fold_left process_name_item ctxt intf.Surface.Ast.intf_code in
|
||||
let ctxt = List.fold_left process_decl_item ctxt intf.Surface.Ast.intf_code in
|
||||
{ ctxt with
|
||||
let ctxt =
|
||||
{
|
||||
ctxt with
|
||||
local = { ctxt.local with used_modules = mod_uses; path = [m] };
|
||||
}
|
||||
in
|
||||
let ctxt =
|
||||
List.fold_left process_name_item ctxt intf.Surface.Ast.intf_code
|
||||
in
|
||||
let ctxt =
|
||||
List.fold_left process_decl_item ctxt intf.Surface.Ast.intf_code
|
||||
in
|
||||
{
|
||||
ctxt with
|
||||
modules = ModuleName.Map.add m ctxt.local ctxt.modules;
|
||||
local = empty_module_ctxt }
|
||||
)
|
||||
local = empty_module_ctxt;
|
||||
})
|
||||
mod_uses ctxt
|
||||
in
|
||||
let ctxt = process_modules empty_ctxt mod_uses in
|
||||
let ctxt = { ctxt with local = { empty_module_ctxt with used_modules = mod_uses } } in
|
||||
let ctxt =
|
||||
{ ctxt with local = { empty_module_ctxt with used_modules = mod_uses } }
|
||||
in
|
||||
let ctxt =
|
||||
List.fold_left
|
||||
(process_law_structure process_name_item)
|
||||
@ -998,9 +1009,12 @@ let form_context (surface, mod_uses) surface_modules : context =
|
||||
ctxt surface.Surface.Ast.program_items
|
||||
in
|
||||
(* Gather struct fields and enum constrs from direct modules: this helps with
|
||||
disambiguation. This is only done towards the root context, because submodules are only interfaces which don't need disambiguation ; and transitive dependencies shouldn't be visible here. *)
|
||||
disambiguation. This is only done towards the root context, because
|
||||
submodules are only interfaces which don't need disambiguation ; and
|
||||
transitive dependencies shouldn't be visible here. *)
|
||||
let sub_constructor_idmap, sub_field_idmap =
|
||||
Ident.Map.fold (fun _ m (cmap, fmap) ->
|
||||
Ident.Map.fold
|
||||
(fun _ m (cmap, fmap) ->
|
||||
let lctx = ModuleName.Map.find m ctxt.modules in
|
||||
let cmap =
|
||||
Ident.Map.union
|
||||
@ -1013,17 +1027,23 @@ let form_context (surface, mod_uses) surface_modules : context =
|
||||
fmap lctx.field_idmap
|
||||
in
|
||||
cmap, fmap)
|
||||
mod_uses (Ident.Map.empty, Ident.Map.empty)
|
||||
mod_uses
|
||||
(Ident.Map.empty, Ident.Map.empty)
|
||||
in
|
||||
{ ctxt with
|
||||
{
|
||||
ctxt with
|
||||
local =
|
||||
{ ctxt.local with
|
||||
(* In the root context, don't disambiguate on submodules structs/enums when there is a conflict *)
|
||||
{
|
||||
ctxt.local with
|
||||
(* In the root context, don't disambiguate on submodules structs/enums
|
||||
when there is a conflict *)
|
||||
constructor_idmap =
|
||||
Ident.Map.union (fun _ base _ -> Some base)
|
||||
Ident.Map.union
|
||||
(fun _ base _ -> Some base)
|
||||
ctxt.local.constructor_idmap sub_constructor_idmap;
|
||||
field_idmap =
|
||||
Ident.Map.union (fun _ base _ -> Some base)
|
||||
Ident.Map.union
|
||||
(fun _ base _ -> Some base)
|
||||
ctxt.local.field_idmap sub_field_idmap;
|
||||
}
|
||||
};
|
||||
}
|
||||
|
@ -70,12 +70,16 @@ type module_context = {
|
||||
(** Gathers the names of the scopes, structs and enums *)
|
||||
field_idmap : StructField.t StructName.Map.t Ident.Map.t;
|
||||
(** The names of the struct fields. Names of fields can be shared between
|
||||
different structs. Note that fields from submodules are included here for the root module, because disambiguating there is helpful. *)
|
||||
different structs. Note that fields from submodules are included here
|
||||
for the root module, because disambiguating there is helpful. *)
|
||||
constructor_idmap : EnumConstructor.t EnumName.Map.t Ident.Map.t;
|
||||
(** The names of the enum constructors. Constructor names can be shared
|
||||
between different enums. Note that constructors from its submodules are included here for the root module, because disambiguating there is helpful. *)
|
||||
between different enums. Note that constructors from its submodules
|
||||
are included here for the root module, because disambiguating there is
|
||||
helpful. *)
|
||||
topdefs : TopdefName.t Ident.Map.t; (** Global definitions *)
|
||||
used_modules : ModuleName.t Ident.Map.t; (** Module aliases and the modules they point to *)
|
||||
used_modules : ModuleName.t Ident.Map.t;
|
||||
(** Module aliases and the modules they point to *)
|
||||
}
|
||||
(** Context for name resolution, valid within a given module *)
|
||||
|
||||
@ -89,9 +93,11 @@ type context = {
|
||||
var_typs : var_sig ScopeVar.Map.t;
|
||||
(** The signatures of each scope variable declared *)
|
||||
modules : module_context ModuleName.Map.t;
|
||||
(** The map to the interfaces of all modules (transitively) used by the program. References are made through [local.used_modules] *)
|
||||
(** The map to the interfaces of all modules (transitively) used by the
|
||||
program. References are made through [local.used_modules] *)
|
||||
local : module_context;
|
||||
(** Local context of the root module corresponding to the program being analysed *)
|
||||
(** Local context of the root module corresponding to the program being
|
||||
analysed *)
|
||||
}
|
||||
(** Global context used throughout {!module: Surface.Desugaring} *)
|
||||
|
||||
@ -177,7 +183,7 @@ val process_type : context -> Surface.Ast.typ -> typ
|
||||
(** {1 API} *)
|
||||
|
||||
val form_context :
|
||||
Surface.Ast.program * ModuleName.t Ident.Map.t
|
||||
-> (Surface.Ast.interface * ModuleName.t Ident.Map.t) ModuleName.Map.t
|
||||
-> context
|
||||
Surface.Ast.program * ModuleName.t Ident.Map.t ->
|
||||
(Surface.Ast.interface * ModuleName.t Ident.Map.t) ModuleName.Map.t ->
|
||||
context
|
||||
(** Derive the context from metadata, in one pass over the declarations *)
|
||||
|
@ -64,13 +64,15 @@ let load_module_interfaces options includes program =
|
||||
in
|
||||
(* modulename * program * (id -> modulename) *)
|
||||
let rec aux req_chain seen uses =
|
||||
List.fold_left (fun (seen, use_map) use ->
|
||||
List.fold_left
|
||||
(fun (seen, use_map) use ->
|
||||
let f = find_module req_chain use.Surface.Ast.mod_use_name in
|
||||
match File.Map.find_opt f seen with
|
||||
| Some (Some (modname, _, _)) ->
|
||||
seen,
|
||||
( seen,
|
||||
Ident.Map.add
|
||||
(Mark.remove use.Surface.Ast.mod_use_alias) modname use_map
|
||||
(Mark.remove use.Surface.Ast.mod_use_alias)
|
||||
modname use_map )
|
||||
| Some None ->
|
||||
Message.raise_multispanned_error
|
||||
(err_req_pos (Mark.get use.Surface.Ast.mod_use_name :: req_chain))
|
||||
@ -82,12 +84,12 @@ let load_module_interfaces options includes program =
|
||||
let seen, sub_use_map =
|
||||
aux
|
||||
(Mark.get use.Surface.Ast.mod_use_name :: req_chain)
|
||||
seen
|
||||
intf.Surface.Ast.intf_submodules
|
||||
seen intf.Surface.Ast.intf_submodules
|
||||
in
|
||||
File.Map.add f (Some (modname, intf, sub_use_map)) seen,
|
||||
( File.Map.add f (Some (modname, intf, sub_use_map)) seen,
|
||||
Ident.Map.add
|
||||
(Mark.remove use.Surface.Ast.mod_use_alias) modname use_map)
|
||||
(Mark.remove use.Surface.Ast.mod_use_alias)
|
||||
modname use_map ))
|
||||
(seen, Ident.Map.empty) uses
|
||||
in
|
||||
let seen =
|
||||
@ -102,7 +104,8 @@ let load_module_interfaces options includes program =
|
||||
in
|
||||
let modules =
|
||||
File.Map.fold
|
||||
(fun _ info acc -> match info with
|
||||
(fun _ info acc ->
|
||||
match info with
|
||||
| None -> acc
|
||||
| Some (mname, intf, use_map) ->
|
||||
ModuleName.Map.add mname (intf, use_map) acc)
|
||||
@ -140,8 +143,7 @@ module Passes = struct
|
||||
Desugared.Linting.lint_program prg;
|
||||
prg, ctx
|
||||
|
||||
let scopelang options ~includes :
|
||||
untyped Scopelang.Ast.program =
|
||||
let scopelang options ~includes : untyped Scopelang.Ast.program =
|
||||
let prg, _ = desugared options ~includes in
|
||||
debug_pass_name "scopelang";
|
||||
let exceptions_graphs =
|
||||
@ -159,8 +161,7 @@ module Passes = struct
|
||||
optimize:bool ->
|
||||
check_invariants:bool ->
|
||||
typed:ty mark ->
|
||||
ty Dcalc.Ast.program
|
||||
* Scopelang.Dependency.TVertex.t list =
|
||||
ty Dcalc.Ast.program * Scopelang.Dependency.TVertex.t list =
|
||||
fun options ~includes ~optimize ~check_invariants ~typed ->
|
||||
let prg = scopelang options ~includes in
|
||||
debug_pass_name "dcalc";
|
||||
@ -220,8 +221,7 @@ module Passes = struct
|
||||
~(typed : ty mark)
|
||||
~avoid_exceptions
|
||||
~closure_conversion :
|
||||
untyped Lcalc.Ast.program
|
||||
* Scopelang.Dependency.TVertex.t list =
|
||||
untyped Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list =
|
||||
let prg, type_ordering =
|
||||
dcalc options ~includes ~optimize ~check_invariants ~typed
|
||||
in
|
||||
@ -283,8 +283,7 @@ module Passes = struct
|
||||
~check_invariants
|
||||
~avoid_exceptions
|
||||
~closure_conversion :
|
||||
Scalc.Ast.program
|
||||
* Scopelang.Dependency.TVertex.t list =
|
||||
Scalc.Ast.program * Scopelang.Dependency.TVertex.t list =
|
||||
let prg, type_ordering =
|
||||
lcalc options ~includes ~optimize ~check_invariants ~typed:Expr.typed
|
||||
~avoid_exceptions ~closure_conversion
|
||||
@ -296,22 +295,20 @@ end
|
||||
module Commands = struct
|
||||
open Cmdliner
|
||||
|
||||
let get_scope_uid (ctx: decl_ctx) (scope : string): ScopeName.t
|
||||
=
|
||||
let get_scope_uid (ctx : decl_ctx) (scope : string) : ScopeName.t =
|
||||
if String.contains scope '.' then
|
||||
Message.raise_error "Only references to the top-level module are allowed";
|
||||
try Ident.Map.find scope ctx.ctx_scope_index with
|
||||
| Ident.Map.Not_found _ ->
|
||||
try Ident.Map.find scope ctx.ctx_scope_index
|
||||
with Ident.Map.Not_found _ ->
|
||||
Message.raise_error
|
||||
"There is no scope @{<yellow>\"%s\"@} inside the program." scope
|
||||
|
||||
(* TODO: this is very weird but I'm trying to maintain the current behaviour
|
||||
for now *)
|
||||
let get_random_scope_uid (ctx: decl_ctx): ScopeName.t =
|
||||
let get_random_scope_uid (ctx : decl_ctx) : ScopeName.t =
|
||||
match Ident.Map.choose_opt ctx.ctx_scope_index with
|
||||
| Some (_, name) -> name
|
||||
| None ->
|
||||
Message.raise_error "There isn't any scope inside the program."
|
||||
| None -> Message.raise_error "There isn't any scope inside the program."
|
||||
|
||||
let get_variable_uid
|
||||
(ctxt : Desugared.Name_resolution.context)
|
||||
@ -333,9 +330,7 @@ module Commands = struct
|
||||
Message.raise_error
|
||||
"Variable @{<yellow>\"%s\"@} not found inside scope @{<yellow>\"%a\"@}"
|
||||
variable ScopeName.format scope_uid
|
||||
| Some
|
||||
(SubScope (subscope_var_name, subscope_name))
|
||||
-> (
|
||||
| Some (SubScope (subscope_var_name, subscope_name)) -> (
|
||||
match second_part with
|
||||
| None ->
|
||||
Message.raise_error
|
||||
|
@ -25,7 +25,6 @@ val main : unit -> unit
|
||||
Each pass takes only its cli options, then calls upon its dependent passes
|
||||
(forwarding their options as needed) *)
|
||||
module Passes : sig
|
||||
|
||||
val surface : Cli.options -> Surface.Ast.program
|
||||
|
||||
val desugared :
|
||||
@ -44,8 +43,7 @@ module Passes : sig
|
||||
optimize:bool ->
|
||||
check_invariants:bool ->
|
||||
typed:'m Shared_ast.mark ->
|
||||
'm Dcalc.Ast.program
|
||||
* Scopelang.Dependency.TVertex.t list
|
||||
'm Dcalc.Ast.program * Scopelang.Dependency.TVertex.t list
|
||||
|
||||
val lcalc :
|
||||
Cli.options ->
|
||||
@ -55,8 +53,7 @@ module Passes : sig
|
||||
typed:'m Shared_ast.mark ->
|
||||
avoid_exceptions:bool ->
|
||||
closure_conversion:bool ->
|
||||
Shared_ast.untyped Lcalc.Ast.program
|
||||
* Scopelang.Dependency.TVertex.t list
|
||||
Shared_ast.untyped Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list
|
||||
|
||||
val scalc :
|
||||
Cli.options ->
|
||||
@ -65,8 +62,7 @@ module Passes : sig
|
||||
check_invariants:bool ->
|
||||
avoid_exceptions:bool ->
|
||||
closure_conversion:bool ->
|
||||
Scalc.Ast.program
|
||||
* Scopelang.Dependency.TVertex.t list
|
||||
Scalc.Ast.program * Scopelang.Dependency.TVertex.t list
|
||||
end
|
||||
|
||||
module Commands : sig
|
||||
@ -85,8 +81,7 @@ module Commands : sig
|
||||
Cli.raw_file option ->
|
||||
string option * ((Format.formatter -> 'a) -> 'a)
|
||||
|
||||
val get_scope_uid :
|
||||
Shared_ast.decl_ctx -> string -> Shared_ast.ScopeName.t
|
||||
val get_scope_uid : Shared_ast.decl_ctx -> string -> Shared_ast.ScopeName.t
|
||||
|
||||
val get_variable_uid :
|
||||
Desugared.Name_resolution.context ->
|
||||
|
@ -91,10 +91,15 @@ let type_program (type m) (prg : m program) : typed program =
|
||||
(fun scope_name _info env ->
|
||||
let scope_sig =
|
||||
match ScopeName.path scope_name with
|
||||
| [] -> (Mark.remove (ScopeName.Map.find scope_name prg.program_scopes)).scope_sig
|
||||
| [] ->
|
||||
(Mark.remove (ScopeName.Map.find scope_name prg.program_scopes))
|
||||
.scope_sig
|
||||
| p ->
|
||||
let m = List.hd (List.rev p) in
|
||||
let scope = ScopeName.Map.find scope_name (ModuleName.Map.find m prg.program_modules) in
|
||||
let scope =
|
||||
ScopeName.Map.find scope_name
|
||||
(ModuleName.Map.find m prg.program_modules)
|
||||
in
|
||||
(Mark.remove scope).scope_sig
|
||||
in
|
||||
let vars =
|
||||
|
@ -60,4 +60,5 @@ type 'm program = {
|
||||
program_topdefs : ('m expr * typ) TopdefName.Map.t;
|
||||
program_lang : Cli.backend_lang;
|
||||
}
|
||||
|
||||
val type_program : 'm program -> typed program
|
||||
|
@ -91,8 +91,8 @@ let rec translate_expr (ctx : ctx) (e : D.expr) : untyped Ast.expr boxed =
|
||||
})
|
||||
m
|
||||
| ELocation (ToplevelVar v) -> Expr.elocation (ToplevelVar v) m
|
||||
| EDStructAccess _ -> assert false
|
||||
(* This shouldn't appear in desugared after disambiguation *)
|
||||
| EDStructAccess _ ->
|
||||
assert false (* This shouldn't appear in desugared after disambiguation *)
|
||||
| EScopeCall { scope; args } ->
|
||||
Expr.escopecall ~scope
|
||||
~args:
|
||||
@ -143,9 +143,9 @@ let rec translate_expr (ctx : ctx) (e : D.expr) : untyped Ast.expr boxed =
|
||||
| op, `Reversed ->
|
||||
Expr.eapp (Expr.eop op (List.rev tys) m1) (List.rev args) m)
|
||||
| EOp _ -> assert false (* Only allowed within [EApp] *)
|
||||
| ( EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _ | EMatch _ | ELit _
|
||||
| EApp _ | EDefault _ | EPureDefault _ | EIfThenElse _ | EArray _
|
||||
| EEmptyError | EErrorOnEmpty _ ) as e ->
|
||||
| ( EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _
|
||||
| EMatch _ | ELit _ | EApp _ | EDefault _ | EPureDefault _ | EIfThenElse _
|
||||
| EArray _ | EEmptyError | EErrorOnEmpty _ ) as e ->
|
||||
Expr.map ~f:(translate_expr ctx) (e, m)
|
||||
|
||||
(** {1 Rule tree construction} *)
|
||||
@ -275,8 +275,7 @@ let scope_to_exception_graphs (scope : D.scope) :
|
||||
List.fold_left
|
||||
(fun exceptions_graphs scope_def_key ->
|
||||
let new_exceptions_graphs = rule_to_exception_graph scope scope_def_key in
|
||||
D.ScopeDef.Map.disjoint_union
|
||||
new_exceptions_graphs exceptions_graphs)
|
||||
D.ScopeDef.Map.disjoint_union new_exceptions_graphs exceptions_graphs)
|
||||
D.ScopeDef.Map.empty scope_ordering
|
||||
|
||||
let build_exceptions_graph (pgrm : D.program) :
|
||||
@ -284,8 +283,7 @@ let build_exceptions_graph (pgrm : D.program) :
|
||||
ScopeName.Map.fold
|
||||
(fun _ scope exceptions_graph ->
|
||||
let new_exceptions_graphs = scope_to_exception_graphs scope in
|
||||
D.ScopeDef.Map.disjoint_union
|
||||
new_exceptions_graphs exceptions_graph)
|
||||
D.ScopeDef.Map.disjoint_union new_exceptions_graphs exceptions_graph)
|
||||
pgrm.program_root.module_scopes D.ScopeDef.Map.empty
|
||||
|
||||
(** Transforms a flat list of rules into a tree, taking into account the
|
||||
@ -772,7 +770,8 @@ let translate_program
|
||||
}
|
||||
in
|
||||
let add_scope_mappings modul ctx =
|
||||
ScopeName.Map.fold (fun _ scdef ctx ->
|
||||
ScopeName.Map.fold
|
||||
(fun _ scdef ctx ->
|
||||
ScopeVar.Map.fold
|
||||
(fun scope_var (states : D.var_or_states) ctx ->
|
||||
let var_name, var_pos = ScopeVar.get_info scope_var in
|
||||
@ -823,9 +822,10 @@ let translate_program
|
||||
in
|
||||
(* Todo: since we rename all scope vars at this point, it would be better to
|
||||
have different types for Desugared.ScopeVar.t and Scopelang.ScopeVar.t *)
|
||||
ModuleName.Map.fold (fun _ m ctx -> add_scope_mappings m ctx)
|
||||
ModuleName.Map.fold
|
||||
(fun _ m ctx -> add_scope_mappings m ctx)
|
||||
desugared.D.program_modules
|
||||
(add_scope_mappings (desugared.D.program_root) ctx)
|
||||
(add_scope_mappings desugared.D.program_root ctx)
|
||||
in
|
||||
let decl_ctx =
|
||||
let ctx_scopes =
|
||||
@ -847,12 +847,11 @@ let translate_program
|
||||
in
|
||||
{ desugared.program_ctx with ctx_scopes }
|
||||
in
|
||||
let ctx = { ctx with decl_ctx }in
|
||||
let ctx = { ctx with decl_ctx } in
|
||||
let program_modules =
|
||||
ModuleName.Map.map (fun m ->
|
||||
ScopeName.Map.map
|
||||
(translate_scope_interface ctx)
|
||||
m.D.module_scopes)
|
||||
ModuleName.Map.map
|
||||
(fun m ->
|
||||
ScopeName.Map.map (translate_scope_interface ctx) m.D.module_scopes)
|
||||
desugared.D.program_modules
|
||||
in
|
||||
let program_topdefs =
|
||||
@ -870,7 +869,8 @@ let translate_program
|
||||
desugared.D.program_root.module_scopes
|
||||
in
|
||||
{
|
||||
Ast.program_module_name = Option.map ModuleName.fresh desugared.D.program_module_name;
|
||||
Ast.program_module_name =
|
||||
Option.map ModuleName.fresh desugared.D.program_module_name;
|
||||
Ast.program_topdefs;
|
||||
Ast.program_scopes;
|
||||
Ast.program_ctx = ctx.decl_ctx;
|
||||
|
@ -146,9 +146,13 @@ type desugared =
|
||||
; defaultTerms : yes
|
||||
; exceptions : no
|
||||
; custom : no >
|
||||
(* Technically, desugared before name resolution has [syntacticNames: yes; resolvedNames: no], and after name resolution has the opposite; but the disambiguation being done by the typer, we don't encode this invariant at the type level.
|
||||
(* Technically, desugared before name resolution has [syntacticNames: yes;
|
||||
resolvedNames: no], and after name resolution has the opposite; but the
|
||||
disambiguation being done by the typer, we don't encode this invariant at the
|
||||
type level.
|
||||
|
||||
Indeed, unfortunately, we cannot express the [<resolvedNames: _; 'a> -> <resolvedNames: yes; 'a>] that would be needed for the typing function. *)
|
||||
Indeed, unfortunately, we cannot express the [<resolvedNames: _; 'a> ->
|
||||
<resolvedNames: yes; 'a>] that would be needed for the typing function. *)
|
||||
|
||||
type scopelang =
|
||||
< monomorphic : yes
|
||||
@ -653,7 +657,8 @@ type 'e code_item =
|
||||
| ScopeDef of ScopeName.t * 'e scope_body
|
||||
| Topdef of TopdefName.t * typ * 'e
|
||||
|
||||
(** A chained list, but with a binder for each element into the next: [x := let a
|
||||
(** A chained list, but with a binder for each element into the next:
|
||||
[x := let a
|
||||
= e1 in e2] is thus [Cons (e1, {a. Cons (e2, {x. Nil})})] *)
|
||||
type 'e code_item_list =
|
||||
| Nil
|
||||
@ -668,8 +673,8 @@ type scope_info = {
|
||||
out_struct_fields : StructField.t ScopeVar.Map.t;
|
||||
}
|
||||
|
||||
type module_tree = M of module_tree ModuleName.Map.t [@@caml.unboxed]
|
||||
(** In practice, this is a DAG: beware of repeated names *)
|
||||
type module_tree = M of module_tree ModuleName.Map.t [@@caml.unboxed]
|
||||
|
||||
type decl_ctx = {
|
||||
ctx_enums : enum_ctx;
|
||||
|
@ -985,8 +985,9 @@ let load_runtime_modules prg =
|
||||
let obj_file =
|
||||
Dynlink.adapt_filename
|
||||
File.(
|
||||
(Pos.get_file (Mark.get (ModuleName.get_info m))
|
||||
/../ ModuleName.to_string m) ^ ".cmo")
|
||||
Pos.get_file (Mark.get (ModuleName.get_info m))
|
||||
/../ ModuleName.to_string m
|
||||
^ ".cmo")
|
||||
in
|
||||
if not (Sys.file_exists obj_file) then
|
||||
Message.raise_spanned_error
|
||||
@ -1007,8 +1008,8 @@ let load_runtime_modules prg =
|
||||
let rec aux acc (M mtree) =
|
||||
ModuleName.Map.fold
|
||||
(fun mname sub acc ->
|
||||
if List.exists (ModuleName.equal mname) acc then acc else
|
||||
mname :: aux acc sub)
|
||||
if List.exists (ModuleName.equal mname) acc then acc
|
||||
else mname :: aux acc sub)
|
||||
mtree acc
|
||||
in
|
||||
List.rev (aux [] prg.decl_ctx.ctx_modules)
|
||||
|
@ -390,8 +390,7 @@ module Env = struct
|
||||
|
||||
let open_scope scope_name t =
|
||||
let scope_vars =
|
||||
A.ScopeVar.Map.disjoint_union
|
||||
t.scope_vars
|
||||
A.ScopeVar.Map.disjoint_union t.scope_vars
|
||||
(A.ScopeName.Map.find scope_name t.scopes)
|
||||
in
|
||||
{ t with scope_vars }
|
||||
@ -469,8 +468,7 @@ and typecheck_expr_top_down :
|
||||
Env.get_scope_var env (Mark.remove name)
|
||||
| SubScopeVar { scope; var; _ } ->
|
||||
Env.get_subscope_out_var env scope (Mark.remove var)
|
||||
| ToplevelVar { name } ->
|
||||
Env.get_toplevel_var env (Mark.remove name)
|
||||
| ToplevelVar { name } -> Env.get_toplevel_var env (Mark.remove name)
|
||||
in
|
||||
let ty =
|
||||
match ty_opt with
|
||||
|
@ -61,8 +61,9 @@ val expr :
|
||||
filling the gaps ([TAny]) if any. Use [Expr.untype] first if this is not
|
||||
what you want.
|
||||
|
||||
Note that typing also transparently performs disambiguation of constructors: [EDStructAccess] nodes are translated into [EStructAccess] with the suitable structure and field idents (this only concerns [desugared] expressions).
|
||||
*)
|
||||
Note that typing also transparently performs disambiguation of constructors:
|
||||
[EDStructAccess] nodes are translated into [EStructAccess] with the suitable
|
||||
structure and field idents (this only concerns [desugared] expressions). *)
|
||||
|
||||
val check_expr :
|
||||
leave_unresolved:bool ->
|
||||
|
@ -313,16 +313,16 @@ and law_structure =
|
||||
| CodeBlock of code_block * source_repr * bool (* Metadata if true *)
|
||||
|
||||
and interface = {
|
||||
intf_modname: uident Mark.pos;
|
||||
intf_code: code_block;
|
||||
(** Invariant: an interface shall only contain [*Decl] elements, or [Topdef]
|
||||
elements with [topdef_expr = None] *)
|
||||
intf_submodules: module_use list;
|
||||
intf_modname : uident Mark.pos;
|
||||
intf_code : code_block;
|
||||
(** Invariant: an interface shall only contain [*Decl] elements, or
|
||||
[Topdef] elements with [topdef_expr = None] *)
|
||||
intf_submodules : module_use list;
|
||||
}
|
||||
|
||||
and module_use = {
|
||||
mod_use_name: uident Mark.pos;
|
||||
mod_use_alias: uident Mark.pos;
|
||||
mod_use_name : uident Mark.pos;
|
||||
mod_use_alias : uident Mark.pos;
|
||||
}
|
||||
|
||||
and program = {
|
||||
|
@ -280,8 +280,8 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) :
|
||||
let mod_use_alias = Option.value ~default:mod_use_name alias in
|
||||
{
|
||||
acc with
|
||||
Ast.program_used_modules = { mod_use_name; mod_use_alias }
|
||||
:: acc.Ast.program_used_modules;
|
||||
Ast.program_used_modules =
|
||||
{ mod_use_name; mod_use_alias } :: acc.Ast.program_used_modules;
|
||||
Ast.program_items = command :: acc.Ast.program_items;
|
||||
}
|
||||
| Ast.LawInclude (Ast.CatalaFile inc_file) ->
|
||||
@ -361,8 +361,12 @@ let get_interface program =
|
||||
| Ast.LawInclude _ | Ast.LawText _ | Ast.ModuleDef _ -> req, acc
|
||||
| Ast.LawHeading (_, str) -> List.fold_left filter (req, acc) str
|
||||
| Ast.ModuleUse (mod_use_name, alias) ->
|
||||
{ Ast.mod_use_name; mod_use_alias = Option.value ~default:mod_use_name alias }
|
||||
:: req, acc
|
||||
( {
|
||||
Ast.mod_use_name;
|
||||
mod_use_alias = Option.value ~default:mod_use_name alias;
|
||||
}
|
||||
:: req,
|
||||
acc )
|
||||
| Ast.CodeBlock (code, _, true) ->
|
||||
( req,
|
||||
List.fold_left
|
||||
@ -395,12 +399,12 @@ let with_sedlex_source source_file f =
|
||||
|
||||
let check_modname program source_file =
|
||||
match program.Ast.program_module_name, source_file with
|
||||
| Some (mname, pos), (Cli.FileName file | Cli.Contents (_, file) | Cli.Stdin file)
|
||||
| ( Some (mname, pos),
|
||||
(Cli.FileName file | Cli.Contents (_, file) | Cli.Stdin file) )
|
||||
when not File.(equal mname Filename.(remove_extension (basename file))) ->
|
||||
Message.raise_spanned_error pos
|
||||
"Module declared as @{<blue>%s@}, which does not match the file name %a"
|
||||
mname
|
||||
File.format file
|
||||
mname File.format file
|
||||
| _ -> ()
|
||||
|
||||
let load_interface source_file =
|
||||
@ -421,9 +425,11 @@ let load_interface source_file =
|
||||
| _ -> "Module_name")
|
||||
in
|
||||
let used_modules, intf = get_interface program in
|
||||
{ Ast.intf_modname = modname;
|
||||
{
|
||||
Ast.intf_modname = modname;
|
||||
Ast.intf_code = intf;
|
||||
Ast.intf_submodules = used_modules; }
|
||||
Ast.intf_submodules = used_modules;
|
||||
}
|
||||
|
||||
let parse_top_level_file (source_file : Cli.input_src) : Ast.program =
|
||||
let program = with_sedlex_source source_file parse_source in
|
||||
|
@ -26,7 +26,8 @@ val lines :
|
||||
|
||||
val load_interface : Cli.input_src -> Ast.interface
|
||||
(** Reads only declarations in metadata in the supplied input file, and only
|
||||
keeps type information. The list of submodules is initialised with names only and empty contents. *)
|
||||
keeps type information. The list of submodules is initialised with names
|
||||
only and empty contents. *)
|
||||
|
||||
val parse_top_level_file : Cli.input_src -> Ast.program
|
||||
(** Parses a catala file (handling file includes) and returns a program.
|
||||
|
Loading…
Reference in New Issue
Block a user