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

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")] ~outputs:[inc (srcv ^ "@test")]
~inputs:[srcv; inc (srcv ^ "@out")] ~inputs:[srcv; inc (srcv ^ "@out")]
~implicit_in: ~implicit_in:
("always" :: ("always"
List.map :: List.map
(fun test -> legacy_test_reference test ^ "@post") (fun test -> legacy_test_reference test ^ "@post")
item.legacy_tests); item.legacy_tests);
results; results;
] ]
else if item.legacy_tests <> [] then 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 keys t = fold (fun k _ acc -> k :: acc) t [] |> List.rev
let values t = fold (fun _ v acc -> v :: 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 of_list l = List.fold_left (fun m (k, v) -> add k v m) empty l
let disjoint_union t1 t2 = let disjoint_union t1 t2 =
union (fun k _ _ -> union
Format.kasprintf failwith (fun k _ _ ->
"Maps are not disjoint: conflict on key %a" Format.kasprintf failwith "Maps are not disjoint: conflict on key %a"
Ord.format k) Ord.format k)
t1 t2 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 get_info (uid : t) : X.info = uid.info
let hash (x : t) : int = x.id let hash (x : t) : int = x.id
let to_string t = X.to_string t.info let to_string t = X.to_string t.info
module Set = Set.Make (Ordering) 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) |> SubScopeName.Map.find (Mark.remove alias)
|> retrieve_in_and_out_typ_or_any var |> retrieve_in_and_out_typ_or_any var
| ELocation (ToplevelVar { name }) -> ( | 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 match Mark.remove typ with
| TArrow (tin, (tout, _)) -> List.map Mark.remove tin, tout | TArrow (tin, (tout, _)) -> List.map Mark.remove tin, tout
| _ -> | _ ->
@ -720,9 +722,7 @@ let translate_rule
didn't seem worth it *) didn't seem worth it *)
| Call (subname, subindex, m) -> | Call (subname, subindex, m) ->
let subscope_sig = ScopeName.Map.find subname ctx.scopes_parameters in let subscope_sig = ScopeName.Map.find subname ctx.scopes_parameters in
let scope_sig_decl = let scope_sig_decl = ScopeName.Map.find subname ctx.decl_ctx.ctx_scopes in
ScopeName.Map.find subname ctx.decl_ctx.ctx_scopes
in
let all_subscope_vars = subscope_sig.scope_sig_local_vars in let all_subscope_vars = subscope_sig.scope_sig_local_vars in
let all_subscope_input_vars = let all_subscope_input_vars =
List.filter List.filter
@ -1082,9 +1082,7 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
External_scope_ref External_scope_ref
(Mark.copy (ScopeName.get_info scope_name) scope_name) (Mark.copy (ScopeName.get_info scope_name) scope_name)
in in
let scope_info = let scope_info = ScopeName.Map.find scope_name decl_ctx.ctx_scopes in
ScopeName.Map.find scope_name decl_ctx.ctx_scopes
in
let scope_sig_in_fields = let scope_sig_in_fields =
(* Output fields have already been generated and added to the program (* Output fields have already been generated and added to the program
ctx at this point, because they are visible to the user (manipulated 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 = let process_scopes scopes =
ScopeName.Map.mapi ScopeName.Map.mapi
(fun scope_name (scope_decl, _) -> (fun scope_name (scope_decl, _) ->
process_scope_sig decl_ctx scope_name scope_decl) process_scope_sig decl_ctx scope_name scope_decl)
scopes scopes
in in
ModuleName.Map.fold (fun _ s -> ModuleName.Map.fold
ScopeName.Map.disjoint_union (fun _ s -> ScopeName.Map.disjoint_union (process_scopes s))
(process_scopes s))
prgm.Scopelang.Ast.program_modules prgm.Scopelang.Ast.program_modules
(process_scopes prgm.Scopelang.Ast.program_scopes) (process_scopes prgm.Scopelang.Ast.program_scopes)
in in
let ctx_structs = let ctx_structs =
ScopeName.Map.fold ScopeName.Map.fold
(fun _ scope_sig_ctx acc -> (fun _ scope_sig_ctx acc ->
let fields = let fields =
ScopeVar.Map.fold ScopeVar.Map.fold
(fun _ sivc acc -> (fun _ sivc acc ->
let pos = Mark.get (StructField.get_info sivc.scope_input_name) in let pos = Mark.get (StructField.get_info sivc.scope_input_name) in
StructField.Map.add sivc.scope_input_name StructField.Map.add sivc.scope_input_name
(sivc.scope_input_typ, pos) (sivc.scope_input_typ, pos)
acc) acc)
scope_sig_ctx.scope_sig_in_fields StructField.Map.empty scope_sig_ctx.scope_sig_in_fields StructField.Map.empty
in in
StructName.Map.add scope_sig_ctx.scope_sig_input_struct fields acc) StructName.Map.add scope_sig_ctx.scope_sig_input_struct fields acc)
scopes_parameters decl_ctx.ctx_structs scopes_parameters decl_ctx.ctx_structs
in in
let decl_ctx = { decl_ctx with ctx_structs } in let decl_ctx = { decl_ctx with ctx_structs } in
let toplevel_vars = let toplevel_vars =
TopdefName.Map.mapi TopdefName.Map.mapi
(fun name (_, ty) -> (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 prgm.Scopelang.Ast.program_topdefs
in in
let ctx = let ctx =

9
compiler/desugared/ast.mli
View File

@ -93,7 +93,7 @@ type io = {
type scope_def = { type scope_def = {
scope_def_rules : rule RuleName.Map.t; 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_typ : typ;
scope_def_parameters : scope_def_parameters :
(Uid.MarkedString.info * Shared_ast.typ) list Mark.pos option; (Uid.MarkedString.info * Shared_ast.typ) list Mark.pos option;
@ -109,7 +109,7 @@ type scope = {
scope_uid : ScopeName.t; scope_uid : ScopeName.t;
scope_defs : scope_def ScopeDef.Map.t; scope_defs : scope_def ScopeDef.Map.t;
scope_assertions : assertion AssertionName.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_options : catala_option Mark.pos list;
scope_meta_assertions : meta_assertion list; scope_meta_assertions : meta_assertion list;
} }
@ -117,13 +117,14 @@ type scope = {
type modul = { type modul = {
module_scopes : scope ScopeName.Map.t; module_scopes : scope ScopeName.Map.t;
module_topdefs : (expr option * typ) TopdefName.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 = { type program = {
program_module_name : Ident.t Mark.pos option; program_module_name : Ident.t Mark.pos option;
program_ctx : decl_ctx; 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_root : modul;
program_lang : Cli.backend_lang; program_lang : Cli.backend_lang;
} }

40
compiler/desugared/disambiguate.ml
View File

@ -73,24 +73,25 @@ let program prg =
let env = let env =
ScopeName.Map.fold ScopeName.Map.fold
(fun scope_name _info env -> (fun scope_name _info env ->
let modul = let modul =
List.fold_left List.fold_left
(fun _ m -> ModuleName.Map.find m prg.program_modules) (fun _ m -> ModuleName.Map.find m prg.program_modules)
prg.program_root (ScopeName.path scope_name) prg.program_root
in (ScopeName.path scope_name)
let scope = ScopeName.Map.find scope_name modul.module_scopes in in
let vars = let scope = ScopeName.Map.find scope_name modul.module_scopes in
ScopeDef.Map.fold let vars =
(fun var def vars -> ScopeDef.Map.fold
match var with (fun var def vars ->
| Var (v, _states) -> ScopeVar.Map.add v def.scope_def_typ vars match var with
| SubScopeVar _ -> vars) | Var (v, _states) -> ScopeVar.Map.add v def.scope_def_typ vars
scope.scope_defs ScopeVar.Map.empty | SubScopeVar _ -> vars)
in scope.scope_defs ScopeVar.Map.empty
(* at this stage, rule resolution and the corresponding encapsulation in
into default terms hasn't taken place, so input and output (* at this stage, rule resolution and the corresponding encapsulation
variables don't need different typing *) into default terms hasn't taken place, so input and output variables
Typing.Env.add_scope scope_name ~vars ~in_vars:vars env) don't need different typing *)
Typing.Env.add_scope scope_name ~vars ~in_vars:vars env)
prg.program_ctx.ctx_scopes env prg.program_ctx.ctx_scopes env
in in
let module_topdefs = let module_topdefs =
@ -102,7 +103,6 @@ let program prg =
prg.program_root.module_topdefs prg.program_root.module_topdefs
in in
let module_scopes = let module_scopes =
ScopeName.Map.map (scope prg.program_ctx env) ScopeName.Map.map (scope prg.program_ctx env) prg.program_root.module_scopes
prg.program_root.module_scopes
in in
{ prg with program_root = { module_topdefs; module_scopes } } { 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 Expr.estruct ~name:s_uid ~fields:s_fields emark
| EnumInject (((path, (constructor, pos_constructor)), _), payload) -> ( | EnumInject (((path, (constructor, pos_constructor)), _), payload) -> (
let get_possible_c_uids ctxt = 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 _ -> with Ident.Map.Not_found _ ->
raise_error_cons_not_found ctxt (constructor, pos_constructor) raise_error_cons_not_found ctxt (constructor, pos_constructor)
in in
@ -1018,7 +1019,9 @@ let process_def
(ctxt : Name_resolution.context) (ctxt : Name_resolution.context)
(prgm : Ast.program) (prgm : Ast.program)
(def : S.definition) : 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 scope_ctxt = ScopeName.Map.find scope_uid ctxt.scopes in
let def_key = let def_key =
Name_resolution.get_def_key Name_resolution.get_def_key
@ -1083,13 +1086,9 @@ let process_def
} }
in in
let module_scopes = let module_scopes =
ScopeName.Map.add scope_uid scope_updated ScopeName.Map.add scope_uid scope_updated prgm.program_root.module_scopes
prgm.program_root.module_scopes
in 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 *) (** Translates a {!type: S.rule} from the surface language *)
let process_rule let process_rule
@ -1108,7 +1107,9 @@ let process_assert
(ctxt : Name_resolution.context) (ctxt : Name_resolution.context)
(prgm : Ast.program) (prgm : Ast.program)
(ass : S.assertion) : 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 = let ass =
translate_expr (Some scope_uid) None ctxt Ident.Map.empty translate_expr (Some scope_uid) None ctxt Ident.Map.empty
(match ass.S.assertion_condition with (match ass.S.assertion_condition with
@ -1140,12 +1141,10 @@ let process_assert
scope.scope_assertions; scope.scope_assertions;
} }
in 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 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 *) (** Translates a surface definition, rule or assertion *)
let process_scope_use_item 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.Assertion ass -> process_assert precond scope ctxt prgm ass
| S.DateRounding (r, _) -> | S.DateRounding (r, _) ->
let scope_uid = scope in 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 = let r =
match r with match r with
| S.Increasing -> Ast.Increasing | S.Increasing -> Ast.Increasing
@ -1188,11 +1189,10 @@ let process_scope_use_item
Mark.copy item (Ast.DateRounding r) :: scope.scope_options; Mark.copy item (Ast.DateRounding r) :: scope.scope_options;
} }
in in
let module_scopes = ScopeName.Map.add scope_uid new_scope prgm.program_root.module_scopes in let module_scopes =
{ ScopeName.Map.add scope_uid new_scope prgm.program_root.module_scopes
prgm with in
program_root = { prgm.program_root with module_scopes } { prgm with program_root = { prgm.program_root with module_scopes } }
}
| _ -> prgm | _ -> prgm
(** {1 Translating top-level items} *) (** {1 Translating top-level items} *)
@ -1267,7 +1267,9 @@ let process_topdef
(prgm : Ast.program) (prgm : Ast.program)
(def : S.top_def) : Ast.program = (def : S.top_def) : Ast.program =
let id = 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 in
let translate_typ t = Name_resolution.process_type ctxt t in let translate_typ t = Name_resolution.process_type ctxt t in
let translate_tbase (tbase, m) = translate_typ (Base tbase, m) in let translate_tbase (tbase, m) = translate_typ (Base tbase, m) in
@ -1391,7 +1393,10 @@ let init_scope_defs
let ctxt = let ctxt =
List.fold_left List.fold_left
(fun ctx m -> (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 ctxt
(ScopeName.path subscope_uid) (ScopeName.path subscope_uid)
in in
@ -1427,24 +1432,22 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) :
let scope_vars = let scope_vars =
Ident.Map.fold Ident.Map.fold
(fun _ v acc -> (fun _ v acc ->
match v with match v with
| SubScope _ -> acc | SubScope _ -> acc
| ScopeVar v -> ( | ScopeVar v -> (
let v_sig = let v_sig = ScopeVar.Map.find v ctxt.Name_resolution.var_typs in
ScopeVar.Map.find v ctxt.Name_resolution.var_typs match v_sig.Name_resolution.var_sig_states_list with
in | [] -> ScopeVar.Map.add v Ast.WholeVar acc
match v_sig.Name_resolution.var_sig_states_list with | states -> ScopeVar.Map.add v (Ast.States states) acc))
| [] -> 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 s_context.Name_resolution.var_idmap ScopeVar.Map.empty
in in
let scope_sub_scopes = let scope_sub_scopes =
Ident.Map.fold Ident.Map.fold
(fun _ v acc -> (fun _ v acc ->
match v with match v with
| ScopeVar _ -> acc | ScopeVar _ -> acc
| SubScope (sub_var, sub_scope) -> | SubScope (sub_var, sub_scope) ->
SubScopeName.Map.add sub_var sub_scope acc) SubScopeName.Map.add sub_var sub_scope acc)
s_context.Name_resolution.var_idmap SubScopeName.Map.empty s_context.Name_resolution.var_idmap SubScopeName.Map.empty
in in
{ {
@ -1458,39 +1461,45 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) :
} }
in in
let get_scopes mctx = 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, _) -> | Name_resolution.TScope (s_uid, _) ->
ScopeName.Map.add s_uid (get_scope s_uid) acc ScopeName.Map.add s_uid (get_scope s_uid) acc
| _ -> acc) | _ -> acc)
mctx.Name_resolution.typedefs ScopeName.Map.empty; mctx.Name_resolution.typedefs ScopeName.Map.empty
in in
let program_modules = let program_modules =
ModuleName.Map.map (fun mctx -> ModuleName.Map.map
{ Ast.module_scopes = get_scopes mctx; (fun mctx ->
{
Ast.module_scopes = get_scopes mctx;
Ast.module_topdefs = Ast.module_topdefs =
Ident.Map.fold (fun _ name acc -> Ident.Map.fold
(fun _ name acc ->
TopdefName.Map.add name TopdefName.Map.add name
(None, ( None,
TopdefName.Map.find name ctxt.Name_resolution.topdef_types) TopdefName.Map.find name ctxt.Name_resolution.topdef_types
acc; )
) acc)
mctx.topdefs TopdefName.Map.empty mctx.topdefs TopdefName.Map.empty;
}) })
ctxt.modules ctxt.modules
in in
let program_ctx = let program_ctx =
let open Name_resolution in let open Name_resolution in
let ctx_scopes mctx acc = let ctx_scopes mctx acc =
Ident.Map.fold (fun _ tydef acc -> Ident.Map.fold
(fun _ tydef acc ->
match tydef with match tydef with
| TScope (s_uid, info) -> | TScope (s_uid, info) -> ScopeName.Map.add s_uid info acc
ScopeName.Map.add s_uid info acc
| _ -> acc) | _ -> acc)
mctx.Name_resolution.typedefs acc mctx.Name_resolution.typedefs acc
in in
let ctx_modules = let ctx_modules =
let rec aux mctx = 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 let sub = aux (ModuleName.Map.find m ctxt.modules) in
M (ModuleName.Map.add m sub acc)) M (ModuleName.Map.add m sub acc))
mctx.used_modules (M ModuleName.Map.empty) 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_structs = ctxt.structs;
ctx_enums = ctxt.enums; ctx_enums = ctxt.enums;
ctx_scopes = ctx_scopes =
ModuleName.Map.fold (fun _ -> ctx_scopes) ModuleName.Map.fold
(fun _ -> ctx_scopes)
ctxt.modules ctxt.modules
(ctx_scopes ctxt.local ScopeName.Map.empty); (ctx_scopes ctxt.local ScopeName.Map.empty);
ctx_topdefs = ctxt.topdef_types; ctx_topdefs = ctxt.topdef_types;
ctx_struct_fields = ctxt.local.field_idmap; ctx_struct_fields = ctxt.local.field_idmap;
ctx_enum_constrs = ctxt.local.constructor_idmap; ctx_enum_constrs = ctxt.local.constructor_idmap;
ctx_scope_index = ctx_scope_index =
Ident.Map.filter_map (fun _ -> function Ident.Map.filter_map
(fun _ -> function
| Name_resolution.TScope (s, _) -> Some s | Name_resolution.TScope (s, _) -> Some s
| _ -> None) | _ -> None)
ctxt.local.typedefs; 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_module_name = surface.Surface.Ast.program_module_name;
Ast.program_modules; Ast.program_modules;
Ast.program_ctx; Ast.program_ctx;
Ast.program_root = { Ast.program_root =
Ast.module_scopes = get_scopes ctxt.Name_resolution.local; {
Ast.module_topdefs = TopdefName.Map.empty; Ast.module_scopes = get_scopes ctxt.Name_resolution.local;
}; Ast.module_topdefs = TopdefName.Map.empty;
};
} }
in in
let process_code_block ctxt prgm block = 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 *) (** The signatures of each scope variable declared *)
modules : module_context ModuleName.Map.t; modules : module_context ModuleName.Map.t;
local : module_context; 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} *) (** Global context used throughout {!module: Surface.Desugaring} *)
@ -257,8 +257,7 @@ let get_module_ctx ctxt id =
let rec module_ctx ctxt path0 = let rec module_ctx ctxt path0 =
match path0 with match path0 with
| [] -> ctxt | [] -> ctxt
| mod_id :: path -> | mod_id :: path -> module_ctx (get_module_ctx ctxt mod_id) path
module_ctx (get_module_ctx ctxt mod_id) path
(** {1 Declarations pass} *) (** {1 Declarations pass} *)
@ -343,7 +342,8 @@ let rec process_base_typ
"This refers to module @{<blue>%s@}, which was not found" modul "This refers to module @{<blue>%s@}, which was not found" modul
| Some mname -> | Some mname ->
let mod_ctxt = ModuleName.Map.find mname ctxt.modules in 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))) Surface.Ast.(Data (Primitive (Named (path, id))), typ_pos)))
(** Process a type (function or not) *) (** Process a type (function or not) *)
@ -463,16 +463,16 @@ let process_struct_decl (ctxt : context) (sdecl : Surface.Ast.struct_decl) :
let structs = let structs =
StructName.Map.update s_uid StructName.Map.update s_uid
(fun fields -> (fun fields ->
match fields with match fields with
| None -> | None ->
Some Some
(StructField.Map.singleton f_uid (StructField.Map.singleton f_uid
(process_type ctxt fdecl.Surface.Ast.struct_decl_field_typ)) (process_type ctxt fdecl.Surface.Ast.struct_decl_field_typ))
| Some fields -> | Some fields ->
Some Some
(StructField.Map.add f_uid (StructField.Map.add f_uid
(process_type ctxt fdecl.Surface.Ast.struct_decl_field_typ) (process_type ctxt fdecl.Surface.Ast.struct_decl_field_typ)
fields)) fields))
ctxt.structs ctxt.structs
in in
{ ctxt with structs }) { ctxt with structs })
@ -508,14 +508,14 @@ let process_enum_decl (ctxt : context) (edecl : Surface.Ast.enum_decl) : context
let enums = let enums =
EnumName.Map.update e_uid EnumName.Map.update e_uid
(fun cases -> (fun cases ->
let typ = let typ =
match cdecl.Surface.Ast.enum_decl_case_typ with match cdecl.Surface.Ast.enum_decl_case_typ with
| None -> TLit TUnit, cdecl_pos | None -> TLit TUnit, cdecl_pos
| Some typ -> process_type ctxt typ | Some typ -> process_type ctxt typ
in in
match cases with match cases with
| None -> Some (EnumConstructor.Map.singleton c_uid typ) | None -> Some (EnumConstructor.Map.singleton c_uid typ)
| Some fields -> Some (EnumConstructor.Map.add c_uid typ fields)) | Some fields -> Some (EnumConstructor.Map.add c_uid typ fields))
ctxt.enums ctxt.enums
in in
{ ctxt with enums }) { ctxt with enums })
@ -602,7 +602,8 @@ let process_scope_decl (ctxt : context) (decl : Surface.Ast.scope_decl) :
| ScopeVar v -> ( | ScopeVar v -> (
try try
let field = 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 in
ScopeVar.Map.add v field svmap ScopeVar.Map.add v field svmap
with StructName.Map.Not_found _ | Ident.Map.Not_found _ -> 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 ctxt.scopes
in in
{ { ctxt with local = { ctxt.local with typedefs }; scopes }
ctxt with
local = { ctxt.local with typedefs };
scopes;
}
| StructDecl sdecl -> | StructDecl sdecl ->
let name, pos = sdecl.struct_decl_name in let name, pos = sdecl.struct_decl_name in
Option.iter Option.iter
@ -684,9 +681,9 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
let typedefs = let typedefs =
Ident.Map.add Ident.Map.add
(Mark.remove sdecl.struct_decl_name) (Mark.remove sdecl.struct_decl_name)
(TStruct s_uid) ctxt.local.typedefs; (TStruct s_uid) ctxt.local.typedefs
in in
{ ctxt with local = { ctxt.local with typedefs} } { ctxt with local = { ctxt.local with typedefs } }
| EnumDecl edecl -> | EnumDecl edecl ->
let name, pos = edecl.enum_decl_name in let name, pos = edecl.enum_decl_name in
Option.iter 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) (Mark.remove edecl.enum_decl_name)
(TEnum e_uid) ctxt.local.typedefs (TEnum e_uid) ctxt.local.typedefs
in in
{ ctxt with local = { ctxt.local with typedefs} } { ctxt with local = { ctxt.local with typedefs } }
| ScopeUse _ -> ctxt | ScopeUse _ -> ctxt
| Topdef def -> | Topdef def ->
let name, pos = def.topdef_name in 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} *) (** {1 API} *)
let empty_module_ctxt = { let empty_module_ctxt =
path = []; {
typedefs = Ident.Map.empty; path = [];
field_idmap = Ident.Map.empty; typedefs = Ident.Map.empty;
constructor_idmap = Ident.Map.empty; field_idmap = Ident.Map.empty;
topdefs = Ident.Map.empty; constructor_idmap = Ident.Map.empty;
used_modules = 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; scopes = ScopeName.Map.empty;
var_typs = ScopeVar.Map.empty; topdef_types = TopdefName.Map.empty;
structs = StructName.Map.empty; var_typs = ScopeVar.Map.empty;
enums = EnumName.Map.empty; structs = StructName.Map.empty;
modules = ModuleName.Map.empty; enums = EnumName.Map.empty;
local = empty_module_ctxt; modules = ModuleName.Map.empty;
} local = empty_module_ctxt;
}
(** Derive the context from metadata, in one pass over the declarations *) (** Derive the context from metadata, in one pass over the declarations *)
let form_context (surface, mod_uses) surface_modules : context = let form_context (surface, mod_uses) surface_modules : context =
let rec process_modules ctxt mod_uses = let rec process_modules ctxt mod_uses =
(* Recursing on [mod_uses] rather than folding on [modules] ensures a topological traversal. *) (* Recursing on [mod_uses] rather than folding on [modules] ensures a
Ident.Map.fold (fun _alias m ctxt -> topological traversal. *)
Ident.Map.fold
(fun _alias m ctxt ->
match ModuleName.Map.find_opt m ctxt.modules with match ModuleName.Map.find_opt m ctxt.modules with
| Some _ -> ctxt | Some _ -> ctxt
| None -> | None ->
let intf, mod_uses = ModuleName.Map.find m surface_modules in let intf, mod_uses = ModuleName.Map.find m surface_modules in
let ctxt = process_modules ctxt mod_uses in let ctxt = process_modules ctxt mod_uses in
let ctxt = { ctxt with let ctxt =
local = { ctxt.local with used_modules = mod_uses; {
path = [m] } } in ctxt with
let ctxt = List.fold_left process_name_item ctxt intf.Surface.Ast.intf_code in local = { ctxt.local with used_modules = mod_uses; path = [m] };
let ctxt = List.fold_left process_decl_item ctxt intf.Surface.Ast.intf_code in }
{ ctxt with 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; modules = ModuleName.Map.add m ctxt.local ctxt.modules;
local = empty_module_ctxt } local = empty_module_ctxt;
) })
mod_uses ctxt mod_uses ctxt
in in
let ctxt = process_modules empty_ctxt mod_uses 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 = let ctxt =
List.fold_left List.fold_left
(process_law_structure process_name_item) (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 ctxt surface.Surface.Ast.program_items
in in
(* Gather struct fields and enum constrs from direct modules: this helps with (* 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 = 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 lctx = ModuleName.Map.find m ctxt.modules in
let cmap = let cmap =
Ident.Map.union Ident.Map.union
@ -1013,17 +1027,23 @@ let form_context (surface, mod_uses) surface_modules : context =
fmap lctx.field_idmap fmap lctx.field_idmap
in in
cmap, fmap) cmap, fmap)
mod_uses (Ident.Map.empty, Ident.Map.empty) mod_uses
(Ident.Map.empty, Ident.Map.empty)
in in
{ ctxt with {
ctxt with
local = 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 = constructor_idmap =
Ident.Map.union (fun _ base _ -> Some base) Ident.Map.union
(fun _ base _ -> Some base)
ctxt.local.constructor_idmap sub_constructor_idmap; ctxt.local.constructor_idmap sub_constructor_idmap;
field_idmap = field_idmap =
Ident.Map.union (fun _ base _ -> Some base) Ident.Map.union
(fun _ base _ -> Some base)
ctxt.local.field_idmap sub_field_idmap; ctxt.local.field_idmap sub_field_idmap;
} };
} }

30
compiler/desugared/name_resolution.mli
View File

@ -65,17 +65,21 @@ type typedef =
type module_context = { type module_context = {
path : Uid.Path.t; 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; 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; field_idmap : StructField.t StructName.Map.t Ident.Map.t;
(** The names of the struct fields. Names of fields can be shared between (** 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; constructor_idmap : EnumConstructor.t EnumName.Map.t Ident.Map.t;
(** The names of the enum constructors. Constructor names can be shared (** 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 *) 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 *) (** Context for name resolution, valid within a given module *)
@ -89,9 +93,11 @@ type context = {
var_typs : var_sig ScopeVar.Map.t; var_typs : var_sig ScopeVar.Map.t;
(** The signatures of each scope variable declared *) (** The signatures of each scope variable declared *)
modules : module_context ModuleName.Map.t; 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 : 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} *) (** Global context used throughout {!module: Surface.Desugaring} *)
@ -177,7 +183,7 @@ val process_type : context -> Surface.Ast.typ -> typ
(** {1 API} *) (** {1 API} *)
val form_context : val form_context :
Surface.Ast.program * ModuleName.t Ident.Map.t Surface.Ast.program * ModuleName.t Ident.Map.t ->
-> (Surface.Ast.interface * ModuleName.t Ident.Map.t) ModuleName.Map.t (Surface.Ast.interface * ModuleName.t Ident.Map.t) ModuleName.Map.t ->
-> context context
(** Derive the context from metadata, in one pass over the declarations *) (** 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 in
(* modulename * program * (id -> modulename) *) (* modulename * program * (id -> modulename) *)
let rec aux req_chain seen uses = 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 let f = find_module req_chain use.Surface.Ast.mod_use_name in
match File.Map.find_opt f seen with match File.Map.find_opt f seen with
| Some (Some (modname, _, _)) -> | Some (Some (modname, _, _)) ->
seen, ( seen,
Ident.Map.add 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 -> | Some None ->
Message.raise_multispanned_error Message.raise_multispanned_error
(err_req_pos (Mark.get use.Surface.Ast.mod_use_name :: req_chain)) (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 = let seen, sub_use_map =
aux aux
(Mark.get use.Surface.Ast.mod_use_name :: req_chain) (Mark.get use.Surface.Ast.mod_use_name :: req_chain)
seen seen intf.Surface.Ast.intf_submodules
intf.Surface.Ast.intf_submodules
in 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 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 (seen, Ident.Map.empty) uses
in in
let seen = let seen =
@ -102,10 +104,11 @@ let load_module_interfaces options includes program =
in in
let modules = let modules =
File.Map.fold File.Map.fold
(fun _ info acc -> match info with (fun _ info acc ->
| None -> acc match info with
| Some (mname, intf, use_map) -> | None -> acc
ModuleName.Map.add mname (intf, use_map) acc) | Some (mname, intf, use_map) ->
ModuleName.Map.add mname (intf, use_map) acc)
file_module_map ModuleName.Map.empty file_module_map ModuleName.Map.empty
in in
root_uses, modules root_uses, modules
@ -140,8 +143,7 @@ module Passes = struct
Desugared.Linting.lint_program prg; Desugared.Linting.lint_program prg;
prg, ctx prg, ctx
let scopelang options ~includes : let scopelang options ~includes : untyped Scopelang.Ast.program =
untyped Scopelang.Ast.program =
let prg, _ = desugared options ~includes in let prg, _ = desugared options ~includes in
debug_pass_name "scopelang"; debug_pass_name "scopelang";
let exceptions_graphs = let exceptions_graphs =
@ -159,8 +161,7 @@ module Passes = struct
optimize:bool -> optimize:bool ->
check_invariants:bool -> check_invariants:bool ->
typed:ty mark -> typed:ty mark ->
ty Dcalc.Ast.program ty Dcalc.Ast.program * Scopelang.Dependency.TVertex.t list =
* Scopelang.Dependency.TVertex.t list =
fun options ~includes ~optimize ~check_invariants ~typed -> fun options ~includes ~optimize ~check_invariants ~typed ->
let prg = scopelang options ~includes in let prg = scopelang options ~includes in
debug_pass_name "dcalc"; debug_pass_name "dcalc";
@ -220,8 +221,7 @@ module Passes = struct
~(typed : ty mark) ~(typed : ty mark)
~avoid_exceptions ~avoid_exceptions
~closure_conversion : ~closure_conversion :
untyped Lcalc.Ast.program untyped Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list =
* Scopelang.Dependency.TVertex.t list =
let prg, type_ordering = let prg, type_ordering =
dcalc options ~includes ~optimize ~check_invariants ~typed dcalc options ~includes ~optimize ~check_invariants ~typed
in in
@ -283,8 +283,7 @@ module Passes = struct
~check_invariants ~check_invariants
~avoid_exceptions ~avoid_exceptions
~closure_conversion : ~closure_conversion :
Scalc.Ast.program Scalc.Ast.program * Scopelang.Dependency.TVertex.t list =
* Scopelang.Dependency.TVertex.t list =
let prg, type_ordering = let prg, type_ordering =
lcalc options ~includes ~optimize ~check_invariants ~typed:Expr.typed lcalc options ~includes ~optimize ~check_invariants ~typed:Expr.typed
~avoid_exceptions ~closure_conversion ~avoid_exceptions ~closure_conversion
@ -296,22 +295,20 @@ end
module Commands = struct module Commands = struct
open Cmdliner 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 if String.contains scope '.' then
Message.raise_error "Only references to the top-level module are allowed"; Message.raise_error "Only references to the top-level module are allowed";
try Ident.Map.find scope ctx.ctx_scope_index with try Ident.Map.find scope ctx.ctx_scope_index
| Ident.Map.Not_found _ -> with Ident.Map.Not_found _ ->
Message.raise_error Message.raise_error
"There is no scope @{<yellow>\"%s\"@} inside the program." scope "There is no scope @{<yellow>\"%s\"@} inside the program." scope
(* TODO: this is very weird but I'm trying to maintain the current behaviour (* TODO: this is very weird but I'm trying to maintain the current behaviour
for now *) 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 match Ident.Map.choose_opt ctx.ctx_scope_index with
| Some (_, name) -> name | Some (_, name) -> name
| None -> | None -> Message.raise_error "There isn't any scope inside the program."
Message.raise_error "There isn't any scope inside the program."
let get_variable_uid let get_variable_uid
(ctxt : Desugared.Name_resolution.context) (ctxt : Desugared.Name_resolution.context)
@ -333,9 +330,7 @@ module Commands = struct
Message.raise_error Message.raise_error
"Variable @{<yellow>\"%s\"@} not found inside scope @{<yellow>\"%a\"@}" "Variable @{<yellow>\"%s\"@} not found inside scope @{<yellow>\"%a\"@}"
variable ScopeName.format scope_uid variable ScopeName.format scope_uid
| Some | Some (SubScope (subscope_var_name, subscope_name)) -> (
(SubScope (subscope_var_name, subscope_name))
-> (
match second_part with match second_part with
| None -> | None ->
Message.raise_error 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 Each pass takes only its cli options, then calls upon its dependent passes
(forwarding their options as needed) *) (forwarding their options as needed) *)
module Passes : sig module Passes : sig
val surface : Cli.options -> Surface.Ast.program val surface : Cli.options -> Surface.Ast.program
val desugared : val desugared :
@ -44,8 +43,7 @@ module Passes : sig
optimize:bool -> optimize:bool ->
check_invariants:bool -> check_invariants:bool ->
typed:'m Shared_ast.mark -> typed:'m Shared_ast.mark ->
'm Dcalc.Ast.program 'm Dcalc.Ast.program * Scopelang.Dependency.TVertex.t list
* Scopelang.Dependency.TVertex.t list
val lcalc : val lcalc :
Cli.options -> Cli.options ->
@ -55,8 +53,7 @@ module Passes : sig
typed:'m Shared_ast.mark -> typed:'m Shared_ast.mark ->
avoid_exceptions:bool -> avoid_exceptions:bool ->
closure_conversion:bool -> closure_conversion:bool ->
Shared_ast.untyped Lcalc.Ast.program Shared_ast.untyped Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list
* Scopelang.Dependency.TVertex.t list
val scalc : val scalc :
Cli.options -> Cli.options ->
@ -65,8 +62,7 @@ module Passes : sig
check_invariants:bool -> check_invariants:bool ->
avoid_exceptions:bool -> avoid_exceptions:bool ->
closure_conversion:bool -> closure_conversion:bool ->
Scalc.Ast.program Scalc.Ast.program * Scopelang.Dependency.TVertex.t list
* Scopelang.Dependency.TVertex.t list
end end
module Commands : sig module Commands : sig
@ -85,8 +81,7 @@ module Commands : sig
Cli.raw_file option -> Cli.raw_file option ->
string option * ((Format.formatter -> 'a) -> 'a) string option * ((Format.formatter -> 'a) -> 'a)
val get_scope_uid : val get_scope_uid : Shared_ast.decl_ctx -> string -> Shared_ast.ScopeName.t
Shared_ast.decl_ctx -> string -> Shared_ast.ScopeName.t
val get_variable_uid : val get_variable_uid :
Desugared.Name_resolution.context -> 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 = let env =
ScopeName.Map.fold ScopeName.Map.fold
(fun scope_name _info env -> (fun scope_name _info env ->
let scope_sig = let scope_sig =
match ScopeName.path scope_name with match ScopeName.path scope_name with
| [] -> (Mark.remove (ScopeName.Map.find scope_name prg.program_scopes)).scope_sig | [] ->
| p -> (Mark.remove (ScopeName.Map.find scope_name prg.program_scopes))
let m = List.hd (List.rev p) in .scope_sig
let scope = ScopeName.Map.find scope_name (ModuleName.Map.find m prg.program_modules) in | p ->
(Mark.remove scope).scope_sig let m = List.hd (List.rev p) in
in let scope =
let vars = ScopeName.Map.find scope_name
ScopeVar.Map.map (fun { svar_out_ty; _ } -> svar_out_ty) scope_sig (ModuleName.Map.find m prg.program_modules)
in in
let in_vars = (Mark.remove scope).scope_sig
ScopeVar.Map.map (fun { svar_in_ty; _ } -> svar_in_ty) scope_sig in
in let vars =
Typing.Env.add_scope scope_name ~vars ~in_vars env) 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 prg.program_ctx.ctx_scopes env
in in
let program_topdefs = 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_topdefs : ('m expr * typ) TopdefName.Map.t;
program_lang : Cli.backend_lang; program_lang : Cli.backend_lang;
} }
val type_program : 'm program -> typed program 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 m
| ELocation (ToplevelVar v) -> Expr.elocation (ToplevelVar v) m | ELocation (ToplevelVar v) -> Expr.elocation (ToplevelVar v) m
| EDStructAccess _ -> assert false | EDStructAccess _ ->
(* This shouldn't appear in desugared after disambiguation *) assert false (* This shouldn't appear in desugared after disambiguation *)
| EScopeCall { scope; args } -> | EScopeCall { scope; args } ->
Expr.escopecall ~scope Expr.escopecall ~scope
~args: ~args:
@ -143,9 +143,9 @@ let rec translate_expr (ctx : ctx) (e : D.expr) : untyped Ast.expr boxed =
| op, `Reversed -> | op, `Reversed ->
Expr.eapp (Expr.eop op (List.rev tys) m1) (List.rev args) m) Expr.eapp (Expr.eop op (List.rev tys) m1) (List.rev args) m)
| EOp _ -> assert false (* Only allowed within [EApp] *) | EOp _ -> assert false (* Only allowed within [EApp] *)
| ( EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _ | EMatch _ | ELit _ | ( EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _
| EApp _ | EDefault _ | EPureDefault _ | EIfThenElse _ | EArray _ | EMatch _ | ELit _ | EApp _ | EDefault _ | EPureDefault _ | EIfThenElse _
| EEmptyError | EErrorOnEmpty _ ) as e -> | EArray _ | EEmptyError | EErrorOnEmpty _ ) as e ->
Expr.map ~f:(translate_expr ctx) (e, m) Expr.map ~f:(translate_expr ctx) (e, m)
(** {1 Rule tree construction} *) (** {1 Rule tree construction} *)
@ -275,8 +275,7 @@ let scope_to_exception_graphs (scope : D.scope) :
List.fold_left List.fold_left
(fun exceptions_graphs scope_def_key -> (fun exceptions_graphs scope_def_key ->
let new_exceptions_graphs = rule_to_exception_graph scope scope_def_key in let new_exceptions_graphs = rule_to_exception_graph scope scope_def_key in
D.ScopeDef.Map.disjoint_union D.ScopeDef.Map.disjoint_union new_exceptions_graphs exceptions_graphs)
new_exceptions_graphs exceptions_graphs)
D.ScopeDef.Map.empty scope_ordering D.ScopeDef.Map.empty scope_ordering
let build_exceptions_graph (pgrm : D.program) : let build_exceptions_graph (pgrm : D.program) :
@ -284,8 +283,7 @@ let build_exceptions_graph (pgrm : D.program) :
ScopeName.Map.fold ScopeName.Map.fold
(fun _ scope exceptions_graph -> (fun _ scope exceptions_graph ->
let new_exceptions_graphs = scope_to_exception_graphs scope in let new_exceptions_graphs = scope_to_exception_graphs scope in
D.ScopeDef.Map.disjoint_union D.ScopeDef.Map.disjoint_union new_exceptions_graphs exceptions_graph)
new_exceptions_graphs exceptions_graph)
pgrm.program_root.module_scopes D.ScopeDef.Map.empty pgrm.program_root.module_scopes D.ScopeDef.Map.empty
(** Transforms a flat list of rules into a tree, taking into account the (** Transforms a flat list of rules into a tree, taking into account the
@ -772,87 +770,88 @@ let translate_program
} }
in in
let add_scope_mappings modul ctx = let add_scope_mappings modul ctx =
ScopeName.Map.fold (fun _ scdef ctx -> ScopeName.Map.fold
(fun _ scdef ctx ->
ScopeVar.Map.fold ScopeVar.Map.fold
(fun scope_var (states : D.var_or_states) ctx -> (fun scope_var (states : D.var_or_states) ctx ->
let var_name, var_pos = ScopeVar.get_info scope_var in let var_name, var_pos = ScopeVar.get_info scope_var in
let new_var = 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 =
match states with match states with
| D.WholeVar -> None | D.WholeVar -> WholeVar (ScopeVar.fresh (var_name, var_pos))
| States (s :: _) -> Some s | States states ->
| States [] -> assert false 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 in
match let reentrant =
D.ScopeDef.Map.find_opt let state =
(Var (scope_var, state)) match states with
scdef.D.scope_defs | D.WholeVar -> None
with | States (s :: _) -> Some s
| Some | States [] -> assert false
{ in
scope_def_io = { io_input = Runtime.Reentrant, _; _ }; match
scope_def_typ; D.ScopeDef.Map.find_opt
_; (Var (scope_var, state))
} -> scdef.D.scope_defs
Some scope_def_typ with
| _ -> None | Some
in {
{ scope_def_io = { io_input = Runtime.Reentrant, _; _ };
ctx with scope_def_typ;
scope_var_mapping = _;
ScopeVar.Map.add scope_var new_var ctx.scope_var_mapping; } ->
reentrant_vars = Some scope_def_typ
Option.fold reentrant | _ -> None
~some:(fun ty -> in
ScopeVar.Map.add scope_var ty ctx.reentrant_vars) {
~none:ctx.reentrant_vars; 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) scdef.D.scope_vars ctx)
modul.D.module_scopes ctx modul.D.module_scopes ctx
in in
(* Todo: since we rename all scope vars at this point, it would be better to (* 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 *) 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 desugared.D.program_modules
(add_scope_mappings (desugared.D.program_root) ctx) (add_scope_mappings desugared.D.program_root ctx)
in in
let decl_ctx = let decl_ctx =
let ctx_scopes = let ctx_scopes =
ScopeName.Map.map ScopeName.Map.map
(fun out_str -> (fun out_str ->
let out_struct_fields = let out_struct_fields =
ScopeVar.Map.fold ScopeVar.Map.fold
(fun var fld out_map -> (fun var fld out_map ->
let var' = let var' =
match ScopeVar.Map.find var ctx.scope_var_mapping with match ScopeVar.Map.find var ctx.scope_var_mapping with
| WholeVar v -> v | WholeVar v -> v
| States l -> snd (List.hd (List.rev l)) | States l -> snd (List.hd (List.rev l))
in in
ScopeVar.Map.add var' fld out_map) ScopeVar.Map.add var' fld out_map)
out_str.out_struct_fields ScopeVar.Map.empty out_str.out_struct_fields ScopeVar.Map.empty
in in
{ out_str with out_struct_fields }) { out_str with out_struct_fields })
desugared.program_ctx.ctx_scopes desugared.program_ctx.ctx_scopes
in in
{ desugared.program_ctx with ctx_scopes } { desugared.program_ctx with ctx_scopes }
in in
let ctx = { ctx with decl_ctx }in let ctx = { ctx with decl_ctx } in
let program_modules = let program_modules =
ModuleName.Map.map (fun m -> ModuleName.Map.map
ScopeName.Map.map (fun m ->
(translate_scope_interface ctx) ScopeName.Map.map (translate_scope_interface ctx) m.D.module_scopes)
m.D.module_scopes)
desugared.D.program_modules desugared.D.program_modules
in in
let program_topdefs = let program_topdefs =
@ -870,7 +869,8 @@ let translate_program
desugared.D.program_root.module_scopes desugared.D.program_root.module_scopes
in 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_topdefs;
Ast.program_scopes; Ast.program_scopes;
Ast.program_ctx = ctx.decl_ctx; Ast.program_ctx = ctx.decl_ctx;

17
compiler/shared_ast/definitions.ml
View File

@ -146,9 +146,13 @@ type desugared =
; defaultTerms : yes ; defaultTerms : yes
; exceptions : no ; exceptions : no
; custom : 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 = type scopelang =
< monomorphic : yes < monomorphic : yes
@ -653,7 +657,8 @@ type 'e code_item =
| ScopeDef of ScopeName.t * 'e scope_body | ScopeDef of ScopeName.t * 'e scope_body
| Topdef of TopdefName.t * typ * 'e | 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})})] *) = e1 in e2] is thus [Cons (e1, {a. Cons (e2, {x. Nil})})] *)
type 'e code_item_list = type 'e code_item_list =
| Nil | Nil
@ -668,8 +673,8 @@ type scope_info = {
out_struct_fields : StructField.t ScopeVar.Map.t; 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 *) (** 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 = { type decl_ctx = {
ctx_enums : enum_ctx; ctx_enums : enum_ctx;
@ -677,10 +682,10 @@ type decl_ctx = {
ctx_scopes : scope_info ScopeName.Map.t; ctx_scopes : scope_info ScopeName.Map.t;
ctx_topdefs : typ TopdefName.Map.t; ctx_topdefs : typ TopdefName.Map.t;
ctx_struct_fields : StructField.t StructName.Map.t Ident.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_enum_constrs : EnumConstructor.t EnumName.Map.t Ident.Map.t;
ctx_scope_index : ScopeName.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; ctx_modules : module_tree;
} }

9
compiler/shared_ast/interpreter.ml
View File

@ -985,8 +985,9 @@ let load_runtime_modules prg =
let obj_file = let obj_file =
Dynlink.adapt_filename Dynlink.adapt_filename
File.( File.(
(Pos.get_file (Mark.get (ModuleName.get_info m)) Pos.get_file (Mark.get (ModuleName.get_info m))
/../ ModuleName.to_string m) ^ ".cmo") /../ ModuleName.to_string m
^ ".cmo")
in in
if not (Sys.file_exists obj_file) then if not (Sys.file_exists obj_file) then
Message.raise_spanned_error Message.raise_spanned_error
@ -1007,8 +1008,8 @@ let load_runtime_modules prg =
let rec aux acc (M mtree) = let rec aux acc (M mtree) =
ModuleName.Map.fold ModuleName.Map.fold
(fun mname sub acc -> (fun mname sub acc ->
if List.exists (ModuleName.equal mname) acc then acc else if List.exists (ModuleName.equal mname) acc then acc
mname :: aux acc sub) else mname :: aux acc sub)
mtree acc mtree acc
in in
List.rev (aux [] prg.decl_ctx.ctx_modules) 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 open_scope scope_name t =
let scope_vars = let scope_vars =
A.ScopeVar.Map.disjoint_union A.ScopeVar.Map.disjoint_union t.scope_vars
t.scope_vars
(A.ScopeName.Map.find scope_name t.scopes) (A.ScopeName.Map.find scope_name t.scopes)
in in
{ t with scope_vars } { t with scope_vars }
@ -469,8 +468,7 @@ and typecheck_expr_top_down :
Env.get_scope_var env (Mark.remove name) Env.get_scope_var env (Mark.remove name)
| SubScopeVar { scope; var; _ } -> | SubScopeVar { scope; var; _ } ->
Env.get_subscope_out_var env scope (Mark.remove var) Env.get_subscope_out_var env scope (Mark.remove var)
| ToplevelVar { name } -> | ToplevelVar { name } -> Env.get_toplevel_var env (Mark.remove name)
Env.get_toplevel_var env (Mark.remove name)
in in
let ty = let ty =
match ty_opt with match ty_opt with
@ -570,8 +568,8 @@ and typecheck_expr_top_down :
(Format.pp_print_list (Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf "@ or@ ") ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ or@ ")
(fun fmt s_name -> (fun fmt s_name ->
Format.fprintf fmt "@{<yellow>\"%a\"@}" A.StructName.format Format.fprintf fmt "@{<yellow>\"%a\"@}" A.StructName.format
s_name)) s_name))
(A.StructName.Map.keys candidate_structs) (A.StructName.Map.keys candidate_structs)
in in
let fld_ty = A.StructField.Map.find field str 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 filling the gaps ([TAny]) if any. Use [Expr.untype] first if this is not
what you want. 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 : val check_expr :
leave_unresolved:bool -> 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 *) | CodeBlock of code_block * source_repr * bool (* Metadata if true *)
and interface = { and interface = {
intf_modname: uident Mark.pos; intf_modname : uident Mark.pos;
intf_code: code_block; intf_code : code_block;
(** Invariant: an interface shall only contain [*Decl] elements, or [Topdef] (** Invariant: an interface shall only contain [*Decl] elements, or
elements with [topdef_expr = None] *) [Topdef] elements with [topdef_expr = None] *)
intf_submodules: module_use list; intf_submodules : module_use list;
} }
and module_use = { and module_use = {
mod_use_name: uident Mark.pos; mod_use_name : uident Mark.pos;
mod_use_alias: uident Mark.pos; mod_use_alias : uident Mark.pos;
} }
and program = { 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 let mod_use_alias = Option.value ~default:mod_use_name alias in
{ {
acc with acc with
Ast.program_used_modules = { mod_use_name; mod_use_alias } Ast.program_used_modules =
:: acc.Ast.program_used_modules; { mod_use_name; mod_use_alias } :: acc.Ast.program_used_modules;
Ast.program_items = command :: acc.Ast.program_items; Ast.program_items = command :: acc.Ast.program_items;
} }
| Ast.LawInclude (Ast.CatalaFile inc_file) -> | Ast.LawInclude (Ast.CatalaFile inc_file) ->
@ -361,8 +361,12 @@ let get_interface program =
| Ast.LawInclude _ | Ast.LawText _ | Ast.ModuleDef _ -> req, acc | Ast.LawInclude _ | Ast.LawText _ | Ast.ModuleDef _ -> req, acc
| Ast.LawHeading (_, str) -> List.fold_left filter (req, acc) str | Ast.LawHeading (_, str) -> List.fold_left filter (req, acc) str
| Ast.ModuleUse (mod_use_name, alias) -> | 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) -> | Ast.CodeBlock (code, _, true) ->
( req, ( req,
List.fold_left List.fold_left
@ -395,12 +399,12 @@ let with_sedlex_source source_file f =
let check_modname program source_file = let check_modname program source_file =
match program.Ast.program_module_name, source_file with 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))) -> when not File.(equal mname Filename.(remove_extension (basename file))) ->
Message.raise_spanned_error pos Message.raise_spanned_error pos
"Module declared as @{<blue>%s@}, which does not match the file name %a" "Module declared as @{<blue>%s@}, which does not match the file name %a"
mname mname File.format file
File.format file
| _ -> () | _ -> ()
let load_interface source_file = let load_interface source_file =
@ -416,14 +420,16 @@ let load_interface source_file =
File.format File.format
(Cli.input_src_file source_file) (Cli.input_src_file source_file)
(match source_file with (match source_file with
| FileName s -> | FileName s ->
String.capitalize_ascii Filename.(basename (remove_extension s)) String.capitalize_ascii Filename.(basename (remove_extension s))
| _ -> "Module_name") | _ -> "Module_name")
in in
let used_modules, intf = get_interface program in let used_modules, intf = get_interface program in
{ Ast.intf_modname = modname; {
Ast.intf_modname = modname;
Ast.intf_code = intf; 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 parse_top_level_file (source_file : Cli.input_src) : Ast.program =
let program = with_sedlex_source source_file parse_source in 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 val load_interface : Cli.input_src -> Ast.interface
(** Reads only declarations in metadata in the supplied input file, and only (** 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 val parse_top_level_file : Cli.input_src -> Ast.program
(** Parses a catala file (handling file includes) and returns a program. (** Parses a catala file (handling file includes) and returns a program.