From 1ae955b50443edb123de4b612bc8c85935567c59 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Thu, 30 Nov 2023 23:53:38 +0100 Subject: [PATCH] Reformat --- build_system/clerk_driver.ml | 8 +- compiler/catala_utils/map.ml | 7 +- compiler/catala_utils/uid.ml | 1 - compiler/dcalc/from_scopelang.ml | 41 +++---- compiler/desugared/ast.mli | 9 +- compiler/desugared/disambiguate.ml | 40 +++---- compiler/desugared/from_surface.ml | 122 ++++++++++--------- compiler/desugared/name_resolution.ml | 156 ++++++++++++++----------- compiler/desugared/name_resolution.mli | 30 +++-- compiler/driver.ml | 57 +++++---- compiler/driver.mli | 13 +-- compiler/scopelang/ast.ml | 35 +++--- compiler/scopelang/ast.mli | 1 + compiler/scopelang/from_desugared.ml | 142 +++++++++++----------- compiler/shared_ast/definitions.ml | 17 ++- compiler/shared_ast/interpreter.ml | 9 +- compiler/shared_ast/typing.ml | 10 +- compiler/shared_ast/typing.mli | 5 +- compiler/surface/ast.ml | 14 +-- compiler/surface/parser_driver.ml | 30 +++-- compiler/surface/parser_driver.mli | 3 +- 21 files changed, 397 insertions(+), 353 deletions(-) diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index fb2243c1..3a553544 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -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 diff --git a/compiler/catala_utils/map.ml b/compiler/catala_utils/map.ml index 1d54d8a8..b7433b51 100644 --- a/compiler/catala_utils/map.ml +++ b/compiler/catala_utils/map.ml @@ -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 diff --git a/compiler/catala_utils/uid.ml b/compiler/catala_utils/uid.ml index 123f066c..7b7bc7d9 100644 --- a/compiler/catala_utils/uid.ml +++ b/compiler/catala_utils/uid.ml @@ -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) diff --git a/compiler/dcalc/from_scopelang.ml b/compiler/dcalc/from_scopelang.ml index a6c4e415..3fbe8e3b 100644 --- a/compiler/dcalc/from_scopelang.ml +++ b/compiler/dcalc/from_scopelang.ml @@ -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 = diff --git a/compiler/desugared/ast.mli b/compiler/desugared/ast.mli index a8f24c07..ddfe13c5 100644 --- a/compiler/desugared/ast.mli +++ b/compiler/desugared/ast.mli @@ -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; } diff --git a/compiler/desugared/disambiguate.ml b/compiler/desugared/disambiguate.ml index b91c5934..917d4dd5 100644 --- a/compiler/desugared/disambiguate.ml +++ b/compiler/desugared/disambiguate.ml @@ -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 } } diff --git a/compiler/desugared/from_surface.ml b/compiler/desugared/from_surface.ml index 00cac405..5412e0e3 100644 --- a/compiler/desugared/from_surface.ml +++ b/compiler/desugared/from_surface.ml @@ -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 = diff --git a/compiler/desugared/name_resolution.ml b/compiler/desugared/name_resolution.ml index 7cea74cb..2b783a4d 100644 --- a/compiler/desugared/name_resolution.ml +++ b/compiler/desugared/name_resolution.ml @@ -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 @{%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; - } + }; } diff --git a/compiler/desugared/name_resolution.mli b/compiler/desugared/name_resolution.mli index ad4ad964..7ca4768c 100644 --- a/compiler/desugared/name_resolution.mli +++ b/compiler/desugared/name_resolution.mli @@ -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 *) diff --git a/compiler/driver.ml b/compiler/driver.ml index 374bb6f6..e1db1de6 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -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 @{\"%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 @{\"%s\"@} not found inside scope @{\"%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 diff --git a/compiler/driver.mli b/compiler/driver.mli index e5335b0c..92e895fd 100644 --- a/compiler/driver.mli +++ b/compiler/driver.mli @@ -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 -> diff --git a/compiler/scopelang/ast.ml b/compiler/scopelang/ast.ml index 6189bd70..63e373a5 100644 --- a/compiler/scopelang/ast.ml +++ b/compiler/scopelang/ast.ml @@ -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 = diff --git a/compiler/scopelang/ast.mli b/compiler/scopelang/ast.mli index 654c4fb3..8a707268 100644 --- a/compiler/scopelang/ast.mli +++ b/compiler/scopelang/ast.mli @@ -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 diff --git a/compiler/scopelang/from_desugared.ml b/compiler/scopelang/from_desugared.ml index 715d539f..2350e5b9 100644 --- a/compiler/scopelang/from_desugared.ml +++ b/compiler/scopelang/from_desugared.ml @@ -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; diff --git a/compiler/shared_ast/definitions.ml b/compiler/shared_ast/definitions.ml index 9f1dbe1e..f18fdffe 100644 --- a/compiler/shared_ast/definitions.ml +++ b/compiler/shared_ast/definitions.ml @@ -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 [ -> ] that would be needed for the typing function. *) + Indeed, unfortunately, we cannot express the [ -> + ] 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; } diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index 140c9b30..2bc5634f 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -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) diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index 75ef112b..a26a52a9 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -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 "@{\"%a\"@}" A.StructName.format - s_name)) + Format.fprintf fmt "@{\"%a\"@}" A.StructName.format + s_name)) (A.StructName.Map.keys candidate_structs) in let fld_ty = A.StructField.Map.find field str in diff --git a/compiler/shared_ast/typing.mli b/compiler/shared_ast/typing.mli index 3004740a..f540ca63 100644 --- a/compiler/shared_ast/typing.mli +++ b/compiler/shared_ast/typing.mli @@ -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 -> diff --git a/compiler/surface/ast.ml b/compiler/surface/ast.ml index 168e073f..771b0f47 100644 --- a/compiler/surface/ast.ml +++ b/compiler/surface/ast.ml @@ -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 = { diff --git a/compiler/surface/parser_driver.ml b/compiler/surface/parser_driver.ml index 7244aa5c..44bbaf1f 100644 --- a/compiler/surface/parser_driver.ml +++ b/compiler/surface/parser_driver.ml @@ -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 @{%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 diff --git a/compiler/surface/parser_driver.mli b/compiler/surface/parser_driver.mli index 091bde57..67193786 100644 --- a/compiler/surface/parser_driver.mli +++ b/compiler/surface/parser_driver.mli @@ -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.