CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-16 14:57:13 +03:00
Code Issues Projects Releases Wiki Activity

Reformat

Browse Source
This commit is contained in:
Louis Gesbert 2023-11-30 23:53:38 +01:00
parent 8df49dcea2
commit 1ae955b504
21 changed files with 397 additions and 353 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
build_system/clerk_driver.ml
View File

@ -729,10 +729,10 @@ let gen_build_statements
~outputs:[inc (srcv ^ "@test")]
~inputs:[srcv; inc (srcv ^ "@out")]
~implicit_in:
("always" ::
List.map
(fun test -> legacy_test_reference test ^ "@post")
item.legacy_tests);
("always"
:: List.map
(fun test -> legacy_test_reference test ^ "@post")
item.legacy_tests);
results;
]
else if item.legacy_tests <> [] then

7
compiler/catala_utils/map.ml
View File

@ -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

1
compiler/catala_utils/uid.ml
View File

@ -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)

41
compiler/dcalc/from_scopelang.ml
View File

@ -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
@ -1134,35 +1132,34 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
let process_scopes scopes =
ScopeName.Map.mapi
(fun scope_name (scope_decl, _) ->
process_scope_sig decl_ctx scope_name scope_decl)
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
let ctx_structs =
ScopeName.Map.fold
(fun _ scope_sig_ctx acc ->
let fields =
ScopeVar.Map.fold
(fun _ sivc acc ->
let pos = Mark.get (StructField.get_info sivc.scope_input_name) in
StructField.Map.add sivc.scope_input_name
(sivc.scope_input_typ, pos)
acc)
scope_sig_ctx.scope_sig_in_fields StructField.Map.empty
in
StructName.Map.add scope_sig_ctx.scope_sig_input_struct fields acc)
let fields =
ScopeVar.Map.fold
(fun _ sivc acc ->
let pos = Mark.get (StructField.get_info sivc.scope_input_name) in
StructField.Map.add sivc.scope_input_name
(sivc.scope_input_typ, pos)
acc)
scope_sig_ctx.scope_sig_in_fields StructField.Map.empty
in
StructName.Map.add scope_sig_ctx.scope_sig_input_struct fields acc)
scopes_parameters decl_ctx.ctx_structs
in
let decl_ctx = { decl_ctx with ctx_structs } in
let toplevel_vars =
TopdefName.Map.mapi
(fun name (_, ty) ->
Var.make (Mark.remove (TopdefName.get_info name)), Mark.remove ty)
Var.make (Mark.remove (TopdefName.get_info name)), Mark.remove ty)
prgm.Scopelang.Ast.program_topdefs
in
let ctx =

9
compiler/desugared/ast.mli
View File

@ -93,7 +93,7 @@ type io = {
type scope_def = {
scope_def_rules : rule RuleName.Map.t;
(** empty outside of the root module *)
(** empty outside of the root module *)
scope_def_typ : typ;
scope_def_parameters :
(Uid.MarkedString.info * Shared_ast.typ) list Mark.pos option;
@ -109,7 +109,7 @@ type scope = {
scope_uid : ScopeName.t;
scope_defs : scope_def ScopeDef.Map.t;
scope_assertions : assertion AssertionName.Map.t;
(** empty outside of the root module *)
(** empty outside of the root module *)
scope_options : catala_option Mark.pos list;
scope_meta_assertions : meta_assertion list;
}
@ -117,13 +117,14 @@ type scope = {
type modul = {
module_scopes : scope ScopeName.Map.t;
module_topdefs : (expr option * typ) TopdefName.Map.t;
(** the expr is [None] outside of the root module *)
(** the expr is [None] outside of the root module *)
}
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;
}

40
compiler/desugared/disambiguate.ml
View File

@ -73,24 +73,25 @@ let program prg =
let env =
ScopeName.Map.fold
(fun scope_name _info env ->
let modul =
List.fold_left
(fun _ m -> ModuleName.Map.find m prg.program_modules)
prg.program_root (ScopeName.path scope_name)
in
let scope = ScopeName.Map.find scope_name modul.module_scopes in
let vars =
ScopeDef.Map.fold
(fun var def vars ->
match var with
| Var (v, _states) -> ScopeVar.Map.add v def.scope_def_typ vars
| SubScopeVar _ -> vars)
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 *)
Typing.Env.add_scope scope_name ~vars ~in_vars:vars env)
let modul =
List.fold_left
(fun _ m -> ModuleName.Map.find m prg.program_modules)
prg.program_root
(ScopeName.path scope_name)
in
let scope = ScopeName.Map.find scope_name modul.module_scopes in
let vars =
ScopeDef.Map.fold
(fun var def vars ->
match var with
| Var (v, _states) -> ScopeVar.Map.add v def.scope_def_typ vars
| SubScopeVar _ -> vars)
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 *)
Typing.Env.add_scope scope_name ~vars ~in_vars:vars env)
prg.program_ctx.ctx_scopes env
in
let module_topdefs =
@ -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 } }

122
compiler/desugared/from_surface.ml
View File

@ -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
@ -1427,24 +1432,22 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) :
let scope_vars =
Ident.Map.fold
(fun _ v acc ->
match v with
| SubScope _ -> acc
| ScopeVar v -> (
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))
match v with
| SubScope _ -> acc
| ScopeVar v -> (
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))
s_context.Name_resolution.var_idmap ScopeVar.Map.empty
in
let scope_sub_scopes =
Ident.Map.fold
(fun _ v acc ->
match v with
| ScopeVar _ -> acc
| SubScope (sub_var, sub_scope) ->
SubScopeName.Map.add sub_var sub_scope acc)
match v with
| ScopeVar _ -> acc
| SubScope (sub_var, sub_scope) ->
SubScopeName.Map.add sub_var sub_scope acc)
s_context.Name_resolution.var_idmap SubScopeName.Map.empty
in
{
@ -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;
)
mctx.topdefs TopdefName.Map.empty
( None,
TopdefName.Map.find name ctxt.Name_resolution.topdef_types
)
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,10 +1532,11 @@ 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.module_scopes = get_scopes ctxt.Name_resolution.local;
Ast.module_topdefs = TopdefName.Map.empty;
};
Ast.program_root =
{
Ast.module_scopes = get_scopes ctxt.Name_resolution.local;
Ast.module_topdefs = TopdefName.Map.empty;
};
}
in
let process_code_block ctxt prgm block =

156
compiler/desugared/name_resolution.ml
View File

@ -88,7 +88,7 @@ type context = {
(** The signatures of each scope variable declared *)
modules : module_context ModuleName.Map.t;
local : module_context;
(** Module being currently analysed (at the end: the root module) *)
(** Module being currently analysed (at the end: the root module) *)
}
(** Global context used throughout {!module: Surface.Desugaring} *)
@ -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) *)
@ -463,16 +463,16 @@ let process_struct_decl (ctxt : context) (sdecl : Surface.Ast.struct_decl) :
let structs =
StructName.Map.update s_uid
(fun fields ->
match fields with
| None ->
Some
(StructField.Map.singleton f_uid
(process_type ctxt fdecl.Surface.Ast.struct_decl_field_typ))
| Some fields ->
Some
(StructField.Map.add f_uid
(process_type ctxt fdecl.Surface.Ast.struct_decl_field_typ)
fields))
match fields with
| None ->
Some
(StructField.Map.singleton f_uid
(process_type ctxt fdecl.Surface.Ast.struct_decl_field_typ))
| Some fields ->
Some
(StructField.Map.add f_uid
(process_type ctxt fdecl.Surface.Ast.struct_decl_field_typ)
fields))
ctxt.structs
in
{ ctxt with structs })
@ -508,14 +508,14 @@ let process_enum_decl (ctxt : context) (edecl : Surface.Ast.enum_decl) : context
let enums =
EnumName.Map.update e_uid
(fun cases ->
let typ =
match cdecl.Surface.Ast.enum_decl_case_typ with
| None -> TLit TUnit, cdecl_pos
| Some typ -> process_type ctxt typ
in
match cases with
| None -> Some (EnumConstructor.Map.singleton c_uid typ)
| Some fields -> Some (EnumConstructor.Map.add c_uid typ fields))
let typ =
match cdecl.Surface.Ast.enum_decl_case_typ with
| None -> TLit TUnit, cdecl_pos
| Some typ -> process_type ctxt typ
in
match cases with
| None -> Some (EnumConstructor.Map.singleton c_uid typ)
| Some fields -> Some (EnumConstructor.Map.add c_uid typ fields))
ctxt.enums
in
{ ctxt with enums })
@ -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,48 +937,62 @@ let process_use_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
(** {1 API} *)
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_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 = {
scopes = ScopeName.Map.empty;
topdef_types = TopdefName.Map.empty;
var_typs = ScopeVar.Map.empty;
structs = StructName.Map.empty;
enums = EnumName.Map.empty;
modules = ModuleName.Map.empty;
local = empty_module_ctxt;
}
let empty_ctxt =
{
scopes = ScopeName.Map.empty;
topdef_types = TopdefName.Map.empty;
var_typs = ScopeVar.Map.empty;
structs = StructName.Map.empty;
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;
}
};
}

30
compiler/desugared/name_resolution.mli
View File

@ -65,17 +65,21 @@ type typedef =
type module_context = {
path : Uid.Path.t;
(** The current path being processed. Used for generating the Uids. *)
(** The current path being processed. Used for generating the Uids. *)
typedefs : typedef Ident.Map.t;
(** Gathers the names of the scopes, structs and enums *)
(** 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. *)
(** 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. *)
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. *)
(** 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. *)
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 *)

57
compiler/driver.ml
View File

@ -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,
Ident.Map.add
(Mark.remove use.Surface.Ast.mod_use_alias) modname use_map
( seen,
Ident.Map.add
(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,
Ident.Map.add
(Mark.remove use.Surface.Ast.mod_use_alias) modname use_map)
( 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 ))
(seen, Ident.Map.empty) uses
in
let seen =
@ -102,10 +104,11 @@ let load_module_interfaces options includes program =
in
let modules =
File.Map.fold
(fun _ info acc -> match info with
| None -> acc
| Some (mname, intf, use_map) ->
ModuleName.Map.add mname (intf, use_map) acc)
(fun _ info acc ->
match info with
| None -> acc
| Some (mname, intf, use_map) ->
ModuleName.Map.add mname (intf, use_map) acc)
file_module_map ModuleName.Map.empty
in
root_uses, modules
@ -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

13
compiler/driver.mli
View File

@ -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 ->

35
compiler/scopelang/ast.ml
View File

@ -89,21 +89,26 @@ let type_program (type m) (prg : m program) : typed program =
let env =
ScopeName.Map.fold
(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
| p ->
let m = List.hd (List.rev p) in
let scope = ScopeName.Map.find scope_name (ModuleName.Map.find m prg.program_modules) in
(Mark.remove scope).scope_sig
in
let vars =
ScopeVar.Map.map (fun { svar_out_ty; _ } -> svar_out_ty) scope_sig
in
let in_vars =
ScopeVar.Map.map (fun { svar_in_ty; _ } -> svar_in_ty) scope_sig
in
Typing.Env.add_scope scope_name ~vars ~in_vars env)
let scope_sig =
match ScopeName.path scope_name with
| [] ->
(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
(Mark.remove scope).scope_sig
in
let vars =
ScopeVar.Map.map (fun { svar_out_ty; _ } -> svar_out_ty) scope_sig
in
let in_vars =
ScopeVar.Map.map (fun { svar_in_ty; _ } -> svar_in_ty) scope_sig
in
Typing.Env.add_scope scope_name ~vars ~in_vars env)
prg.program_ctx.ctx_scopes env
in
let program_topdefs =

1
compiler/scopelang/ast.mli
View File

@ -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

142
compiler/scopelang/from_desugared.ml
View File

@ -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,87 +770,88 @@ 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
let new_var =
match states with
| D.WholeVar -> WholeVar (ScopeVar.fresh (var_name, var_pos))
| States states ->
let var_prefix = var_name ^ "_" in
let state_var state =
ScopeVar.fresh
(Mark.map (( ^ ) var_prefix) (StateName.get_info state))
in
States (List.map (fun state -> state, state_var state) states)
in
let reentrant =
let state =
let var_name, var_pos = ScopeVar.get_info scope_var in
let new_var =
match states with
| D.WholeVar -> None
| States (s :: _) -> Some s
| States [] -> assert false
| D.WholeVar -> WholeVar (ScopeVar.fresh (var_name, var_pos))
| States states ->
let var_prefix = var_name ^ "_" in
let state_var state =
ScopeVar.fresh
(Mark.map (( ^ ) var_prefix) (StateName.get_info state))
in
States (List.map (fun state -> state, state_var state) states)
in
match
D.ScopeDef.Map.find_opt
(Var (scope_var, state))
scdef.D.scope_defs
with
| Some
{
scope_def_io = { io_input = Runtime.Reentrant, _; _ };
scope_def_typ;
_;
} ->
Some scope_def_typ
| _ -> None
in
{
ctx with
scope_var_mapping =
ScopeVar.Map.add scope_var new_var ctx.scope_var_mapping;
reentrant_vars =
Option.fold reentrant
~some:(fun ty ->
ScopeVar.Map.add scope_var ty ctx.reentrant_vars)
~none:ctx.reentrant_vars;
})
let reentrant =
let state =
match states with
| D.WholeVar -> None
| States (s :: _) -> Some s
| States [] -> assert false
in
match
D.ScopeDef.Map.find_opt
(Var (scope_var, state))
scdef.D.scope_defs
with
| Some
{
scope_def_io = { io_input = Runtime.Reentrant, _; _ };
scope_def_typ;
_;
} ->
Some scope_def_typ
| _ -> None
in
{
ctx with
scope_var_mapping =
ScopeVar.Map.add scope_var new_var ctx.scope_var_mapping;
reentrant_vars =
Option.fold reentrant
~some:(fun ty ->
ScopeVar.Map.add scope_var ty ctx.reentrant_vars)
~none:ctx.reentrant_vars;
})
scdef.D.scope_vars ctx)
modul.D.module_scopes ctx
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 =
ScopeName.Map.map
(fun out_str ->
let out_struct_fields =
ScopeVar.Map.fold
(fun var fld out_map ->
let var' =
match ScopeVar.Map.find var ctx.scope_var_mapping with
| WholeVar v -> v
| States l -> snd (List.hd (List.rev l))
in
ScopeVar.Map.add var' fld out_map)
out_str.out_struct_fields ScopeVar.Map.empty
in
{ out_str with out_struct_fields })
let out_struct_fields =
ScopeVar.Map.fold
(fun var fld out_map ->
let var' =
match ScopeVar.Map.find var ctx.scope_var_mapping with
| WholeVar v -> v
| States l -> snd (List.hd (List.rev l))
in
ScopeVar.Map.add var' fld out_map)
out_str.out_struct_fields ScopeVar.Map.empty
in
{ out_str with out_struct_fields })
desugared.program_ctx.ctx_scopes
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;

17
compiler/shared_ast/definitions.ml
View File

@ -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;
@ -677,10 +682,10 @@ type decl_ctx = {
ctx_scopes : scope_info ScopeName.Map.t;
ctx_topdefs : typ TopdefName.Map.t;
ctx_struct_fields : StructField.t StructName.Map.t Ident.Map.t;
(** needed for disambiguation (desugared -> scope) *)
(** needed for disambiguation (desugared -> scope) *)
ctx_enum_constrs : EnumConstructor.t EnumName.Map.t Ident.Map.t;
ctx_scope_index : ScopeName.t Ident.Map.t;
(** only used to lookup scopes (in the root module) specified from the cli *)
(** only used to lookup scopes (in the root module) specified from the cli *)
ctx_modules : module_tree;
}

9
compiler/shared_ast/interpreter.ml
View File

@ -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)

10
compiler/shared_ast/typing.ml
View File

@ -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
@ -570,8 +568,8 @@ and typecheck_expr_top_down :
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf "@ or@ ")
(fun fmt s_name ->
Format.fprintf fmt "@{<yellow>\"%a\"@}" A.StructName.format
s_name))
Format.fprintf fmt "@{<yellow>\"%a\"@}" A.StructName.format
s_name))
(A.StructName.Map.keys candidate_structs)
in
let fld_ty = A.StructField.Map.find field str in

5
compiler/shared_ast/typing.mli
View File

@ -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 ->

14
compiler/surface/ast.ml
View File

@ -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 = {

30
compiler/surface/parser_driver.ml
View File

@ -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 =
@ -416,14 +420,16 @@ let load_interface source_file =
File.format
(Cli.input_src_file source_file)
(match source_file with
| FileName s ->
String.capitalize_ascii Filename.(basename (remove_extension s))
| _ -> "Module_name")
| FileName s ->
String.capitalize_ascii Filename.(basename (remove_extension s))
| _ -> "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

3
compiler/surface/parser_driver.mli
View File

@ -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.