diff --git a/compiler/desugared/from_surface.ml b/compiler/desugared/from_surface.ml index 5179e304..30d3ac66 100644 --- a/compiler/desugared/from_surface.ml +++ b/compiler/desugared/from_surface.ml @@ -454,7 +454,7 @@ let rec translate_expr Expr.elocation (DesugaredScopeVar { name = uid, pos; state = x_state }) emark - | Some (SubScope (uid, _, _)) -> + | Some (SubScope (uid, _)) -> Expr.elocation (DesugaredScopeVar { name = uid, pos; state = None }) emark @@ -1563,7 +1563,7 @@ let init_scope_defs let add_def _ v scope_def_map = let pos = match v with - | ScopeVar v | SubScope (v, _, _) -> Mark.get (ScopeVar.get_info v) + | ScopeVar v | SubScope (v, _) -> Mark.get (ScopeVar.get_info v) in let new_def v_sig io = { @@ -1607,8 +1607,11 @@ let init_scope_defs (scope_def_map, 0) states in scope_def) - | SubScope (v0, subscope_uid, forward_out) -> + | SubScope (v0, subscope_uid) -> let sub_scope_def = Name_resolution.get_scope_context ctxt subscope_uid in + let forward_out = + (Name_resolution.get_var_io ctxt v0).scope_decl_context_io_output + in let ctxt = List.fold_left (fun ctx m -> @@ -1690,7 +1693,7 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) : (fun _ v acc -> match v with | ScopeVar _ -> acc - | SubScope (sub_var, sub_scope, _) -> + | SubScope (sub_var, sub_scope) -> ScopeVar.Map.add sub_var sub_scope acc) s_context.Name_resolution.var_idmap ScopeVar.Map.empty in diff --git a/compiler/desugared/name_resolution.ml b/compiler/desugared/name_resolution.ml index 3f0f5b9e..b62ada4f 100644 --- a/compiler/desugared/name_resolution.ml +++ b/compiler/desugared/name_resolution.ml @@ -144,7 +144,7 @@ let get_subscope_uid ((y, pos) : Ident.t Mark.pos) : ScopeVar.t = let scope = get_scope_context ctxt scope_uid in match Ident.Map.find_opt y scope.var_idmap with - | Some (SubScope (sub_uid, _sub_id, _)) -> sub_uid + | Some (SubScope (sub_uid, _sub_id)) -> sub_uid | _ -> raise_unknown_identifier "for a subscope of this scope" (y, pos) (** [is_subscope_uid scope_uid ctxt y] returns true if [y] belongs to the @@ -251,9 +251,15 @@ let process_subscope_decl (ctxt : context) (decl : Surface.Ast.scope_decl_context_scope) : context = let name, name_pos = decl.scope_decl_context_scope_name in - let forward_output = - decl.Surface.Ast.scope_decl_context_scope_attribute - .scope_decl_context_io_output + let subscope_io = + { + Surface.Ast.scope_decl_context_io_output = + decl.Surface.Ast.scope_decl_context_scope_attribute + .scope_decl_context_io_output; + scope_decl_context_io_input = + decl.Surface.Ast.scope_decl_context_scope_attribute + .scope_decl_context_io_input; + } in let (path, subscope), s_pos = decl.scope_decl_context_scope_sub_scope in let scope_ctxt = get_scope_context ctxt scope in @@ -262,7 +268,7 @@ let process_subscope_decl let info = match use with | ScopeVar v -> ScopeVar.get_info v - | SubScope (ssc, _, _) -> ScopeVar.get_info ssc + | SubScope (ssc, _) -> ScopeVar.get_info ssc in Message.error ~extra_pos:["first use", Mark.get info; "second use", s_pos] @@ -278,13 +284,34 @@ let process_subscope_decl scope_ctxt with var_idmap = Ident.Map.add name - (SubScope (sub_scope_uid, original_subscope_uid, forward_output)) + (SubScope (sub_scope_uid, original_subscope_uid)) scope_ctxt.var_idmap; sub_scopes = ScopeName.Set.add original_subscope_uid scope_ctxt.sub_scopes; } in - { ctxt with scopes = ScopeName.Map.add scope scope_ctxt ctxt.scopes } + let subscope_ctxt = get_scope_context ctxt original_subscope_uid in + { + ctxt with + scopes = ScopeName.Map.add scope scope_ctxt ctxt.scopes; + var_typs = + ScopeVar.Map.add sub_scope_uid + { + var_sig_typ = + ( TArrow + ( [TStruct subscope_ctxt.scope_in_struct, name_pos], + (TStruct subscope_ctxt.scope_out_struct, name_pos) ), + name_pos ); + var_sig_is_condition = false; + var_sig_parameters = None; + (* We do not populate the parameter field for sub-scopes as the + parameters are the scope's input variables. *) + var_sig_io = subscope_io; + var_sig_states_idmap = Shared_ast.Ident.Map.empty; + var_sig_states_list = []; + } + ctxt.var_typs; + } let is_type_cond ((typ, _) : Surface.Ast.typ) = match typ with @@ -365,7 +392,7 @@ let process_data_decl let info = match use with | ScopeVar v -> ScopeVar.get_info v - | SubScope (ssc, _, _) -> ScopeVar.get_info ssc + | SubScope (ssc, _) -> ScopeVar.get_info ssc in Message.error ~extra_pos:["First use:", Mark.get info; "Second use:", pos] @@ -616,15 +643,17 @@ let process_scope_decl Ident.Map.fold (fun id var svmap -> match var with - | SubScope (_, _, (false, _)) -> svmap - | ScopeVar v | SubScope (v, _, (true, _)) -> ( - try - let field = - 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)) + | ScopeVar v | SubScope (v, _) -> + let is_output = (get_var_io ctxt v).scope_decl_context_io_output in + if Mark.remove is_output then + try + let field = + 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 + else svmap) sco.var_idmap ScopeVar.Map.empty in let typedefs = @@ -829,7 +858,7 @@ let get_def_key | [y; x] -> let (subscope_var, name) : ScopeVar.t * ScopeName.t = match Ident.Map.find_opt (Mark.remove y) scope_ctxt.var_idmap with - | Some (SubScope (v, u, _)) -> v, u + | Some (SubScope (v, u)) -> v, u | Some _ -> Message.error ~pos "Invalid definition,@ %a@ is@ not@ a@ subscope" Print.lit_style (Mark.remove y) diff --git a/compiler/driver.ml b/compiler/driver.ml index dee57b8e..b71fb035 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -395,7 +395,7 @@ module Commands = struct Message.error "Variable @{\"%s\"@} not found inside scope @{\"%a\"@}" variable ScopeName.format scope_uid - | Some (ScopeVar v | SubScope (v, _, _)) -> + | Some (ScopeVar v | SubScope (v, _)) -> let state = second_part |> Option.map @@ -1238,4 +1238,9 @@ module Plugin = struct let name = String.lowercase_ascii name in let info = Cmdliner.Cmd.info name ?man ?doc ~docs:Cli.s_plugins in Plugin.register info term + + let register_subcommands name ?man ?doc cmds = + let name = String.lowercase_ascii name in + let info = Cmdliner.Cmd.info name ?man ?doc ~docs:Cli.s_plugins in + Plugin.register_subcommands info cmds end diff --git a/compiler/driver.mli b/compiler/driver.mli index bfa37335..8e0be679 100644 --- a/compiler/driver.mli +++ b/compiler/driver.mli @@ -119,4 +119,11 @@ module Plugin : sig ?doc:string -> (Global.options -> unit) Cmdliner.Term.t -> unit + + val register_subcommands : + string -> + ?man:Cmdliner.Manpage.block list -> + ?doc:string -> + unit Cmdliner.Cmd.t list -> + unit end diff --git a/compiler/plugin.ml b/compiler/plugin.ml index c42e9789..2a5e3ccf 100644 --- a/compiler/plugin.ml +++ b/compiler/plugin.ml @@ -26,6 +26,10 @@ let register info term = Hashtbl.replace backend_plugins name (Cmd.v info Term.(term $ Cli.Flags.Global.options)) +let register_subcommands info cmds = + let name = String.lowercase_ascii (Cmd.name (Cmd.v info (Term.const ()))) in + Hashtbl.replace backend_plugins name (Cmd.group info cmds) + let list () = Hashtbl.to_seq_values backend_plugins |> List.of_seq let names () = Hashtbl.to_seq_keys backend_plugins |> List.of_seq let load_failures = Hashtbl.create 17 diff --git a/compiler/plugin.mli b/compiler/plugin.mli index 7278403b..359d8230 100644 --- a/compiler/plugin.mli +++ b/compiler/plugin.mli @@ -28,6 +28,13 @@ val register : [--plugins-dirs] to be handled correctly, and for setting debug flags), but can add more. *) +val register_subcommands : Cmdliner.Cmd.info -> unit Cmdliner.Cmd.t list -> unit +(** This alternative to [register] allows to register plugins that define + multiple subcommands (e.g. [catala myplugin subcommand --help]). Be aware + that all subcommands should take the [Catala_utils.Cli.Flags.Global.options] + term that handles the [--plugins-dirs] flags and performs some + initialisations. *) + (** {2 catala-facing API} *) val list : unit -> t list diff --git a/compiler/shared_ast/definitions.ml b/compiler/shared_ast/definitions.ml index 3e16491c..4ca33cd9 100644 --- a/compiler/shared_ast/definitions.ml +++ b/compiler/shared_ast/definitions.ml @@ -97,8 +97,7 @@ module ScopeVar = type scope_var_or_subscope = | ScopeVar of ScopeVar.t - | SubScope of ScopeVar.t * ScopeName.t * bool Mark.pos -(* The bool is true if the output of the subscope is to be forwarded *) + | SubScope of ScopeVar.t * ScopeName.t module StateName = Uid.Gen