Small interface improvements (#704)

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

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)

compiler/driver.ml

@@ -395,7 +395,7 @@ module Commands = struct
       Message.error
         "Variable @{<yellow>\"%s\"@} not found inside scope @{<yellow>\"%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

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

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

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

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