annotation filters with cli arguments

atd/src/annot.ml

@@ -214,3 +214,16 @@ let validate schema root =
   List.iter (fun sec ->
     validate_section sec root
   ) schema
+
+let filter_by_tags ~tags full_module =
+  let aux (annot : t) =
+    annot |> List.filter (fun (section, _) -> (
+      match fields annot ~section ~field:"tag" with
+      | [] -> true
+      | fields ->
+          fields
+          |> List.filter_map snd 
+          |> List.exists (fun value -> List.mem value tags)
+    ))
+  in
+  Ast.map_all_annot aux full_module

atd/src/annot.mli

@@ -203,3 +203,10 @@ type schema = schema_section list
 (** Check that annotations of interest are not misplaced.
     Raises an exception with an error message when the check fails. *)
 val validate : schema -> Ast.any -> unit
+
+(**
+   Remove annotations which do not have at least one of the provided [tags] found in their tag field.
+*)
+val filter_by_tags :
+  tags : string list ->
+  Ast.full_module -> Ast.full_module

atd/src/json.ml

@@ -90,6 +90,12 @@ let annot_schema_json : Annot.schema = [
       Variant, "name";
       Field, "name";
       Field, "tag_field";
+      Module_head, "tag";
+      Type_def, "tag";
+      Type_expr, "tag";
+      Variant, "tag";
+      Cell, "tag";
+      Field, "tag";
     ]
   };
   {

atd/src/util.ml

@@ -8,6 +8,7 @@ let read_lexbuf
     ?(inherit_variants = false)
     ?(pos_fname = "")
     ?(pos_lnum = 1)
+    ~tags
     lexbuf =
 
   Lexer.init_fname lexbuf pos_fname pos_lnum;
@@ -30,12 +31,16 @@ let read_lexbuf
    | Some schema ->
        Annot.validate schema (Ast.Full_module full_module)
   );
+  let full_module = match tags with 
+    | [] -> full_module 
+    | tags -> Annot.filter_by_tags ~tags full_module
+  in
   (full_module, original_types)
 
 let read_channel
     ?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug
     ?inherit_fields ?inherit_variants
-    ?pos_fname ?pos_lnum
+    ?pos_fname ?pos_lnum ~tags
     ic =
   let lexbuf = Lexing.from_channel ic in
   let pos_fname =
@@ -45,12 +50,12 @@ let read_channel
       pos_fname
   in
   read_lexbuf ?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug
-    ?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum lexbuf
+    ?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum ~tags lexbuf
 
 let load_file
     ?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug
     ?inherit_fields ?inherit_variants
-    ?pos_fname ?pos_lnum
+    ?pos_fname ?pos_lnum ~tags
     file =
   let ic = open_in file in
   let finally () = close_in_noerr ic in
@@ -63,7 +68,7 @@ let load_file
     let ast =
       read_channel
         ?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug
-        ?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum ic
+        ?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum ~tags ic
     in
     finally ();
     ast
@@ -74,11 +79,11 @@ let load_file
 let load_string
     ?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug
     ?inherit_fields ?inherit_variants
-    ?pos_fname ?pos_lnum
+    ?pos_fname ?pos_lnum ~tags
     s =
   let lexbuf = Lexing.from_string s in
   read_lexbuf ?annot_schema ?expand ?keep_builtins ?keep_poly ?xdebug
-    ?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum lexbuf
+    ?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum ~tags lexbuf
 
 module Tsort = Sort.Make (
   struct

atd/src/util.mli

@@ -10,6 +10,7 @@ val read_lexbuf :
   ?inherit_variants:bool ->
   ?pos_fname:string ->
   ?pos_lnum:int ->
+  tags:string list ->
   Lexing.lexbuf -> Ast.full_module * Expand.original_types
   (** Read an ATD file from a lexbuf. See also [read_channel], [load_file]
       and [load_string].
@@ -66,6 +67,7 @@ val read_channel :
   ?inherit_variants:bool ->
   ?pos_fname:string ->
   ?pos_lnum:int ->
+  tags:string list ->
   in_channel -> Ast.full_module * Expand.original_types
   (** Read an ATD file from an [in_channel]. Options: see [read_lexbuf].
       The default [pos_fname] is set to ["<stdin>"] when appropriate. *)
@@ -80,6 +82,7 @@ val load_file :
   ?inherit_variants:bool ->
   ?pos_fname:string ->
   ?pos_lnum:int ->
+  tags:string list ->
   string -> Ast.full_module * Expand.original_types
   (** Read an ATD file. Options: see [read_lexbuf].
       The default [pos_fname] is the given input file name. *)
@@ -94,6 +97,7 @@ val load_string :
   ?inherit_variants:bool ->
   ?pos_fname:string ->
   ?pos_lnum:int ->
+  tags:string list ->
   string -> Ast.full_module * Expand.original_types
   (** Read ATD data from a string. Options: see [read_lexbuf]. *)
 

atd/test/annot.ml

@@ -31,11 +31,11 @@ let schema : Atd.Annot.schema = [
 ]
 
 let test_valid_input atd_input =
-  let root, _orig_types = Atd.Util.load_string atd_input in
+  let root, _orig_types = Atd.Util.load_string ~tags:[] atd_input in
   Atd.Annot.validate schema (Atd.Ast.Full_module root)
 
 let test_invalid_input atd_input =
-  let root, _orig_types = Atd.Util.load_string atd_input in
+  let root, _orig_types = Atd.Util.load_string ~tags:[] atd_input in
   try
     Atd.Annot.validate schema (Atd.Ast.Full_module root);
     assert false

atdcat/src/atdcat.ml

@@ -78,7 +78,7 @@ let parse
       fun file ->
         let m, _orig_defs =
           Atd.Util.load_file ~annot_schema ~expand ~keep_poly ~xdebug
-            ~inherit_fields ~inherit_variants file
+            ~inherit_fields ~inherit_variants ~tags:[] file
         in
         if remove_wraps then
           Atd.Ast.remove_wrap_constructs m

atdcpp/src/bin/Atdcpp_main.ml

@@ -7,6 +7,7 @@ open Cmdliner
 
 type conf = {
   input_files: string list;
+  tags: string list;
   version: bool;
 }
 
@@ -18,7 +19,7 @@ let run conf =
   else
     conf.input_files
     |> List.iter (fun atd_file ->
-      Atdcpp.Codegen.run_file atd_file
+      Atdcpp.Codegen.run_file ~tags:conf.tags atd_file
     )
 
 (***************************************************************************)
@@ -38,6 +39,13 @@ let input_files_term =
   let default = [] in
   Arg.value (Arg.pos_all Arg.file default info)
 
+let tags_term =
+  let info =
+    Arg.info ["tag"]
+      ~doc:"Only evaluate annotations which have either the provided TAG as a field value <... tag=TAG>, or have no tags specified.\nOption can be used multiple times to specify several tags"
+  in
+  Arg.value (Arg.opt_all Arg.string [] info)
+
 let version_term =
   let info =
     Arg.info ["version"]
@@ -94,14 +102,16 @@ type bar = [
 ]
 
 let cmdline_term run =
-  let combine input_files version =
+  let combine input_files tags version =
     run {
       input_files;
       version;
+      tags;
     }
   in
   Term.(const combine
         $ input_files_term
+        $ tags_term
         $ version_term
        )
 

atdcpp/src/lib/Codegen.ml

@@ -34,6 +34,12 @@ let annot_schema_cpp : Atd.Annot.schema_section =
       Field, "default";
       Module_head, "include";
       Module_head, "namespace";
+      Module_head, "tag";
+      Type_def, "tag";
+      Type_expr, "tag";
+      Variant, "tag";
+      Cell, "tag";
+      Field, "tag";
     ]
   }
 
@@ -1576,7 +1582,7 @@ let to_cpp_file ~atd_filename (items : A.module_body) dst_path namespace_name =
   |> double_spaced
   |> Indent.to_file ~indent:4 dst_path
 
-let run_file src_path =
+let run_file ~tags src_path =
   let src_name = Filename.basename src_path in
   let dst_name =
     (if Filename.check_suffix src_name ".atd" then
@@ -1594,6 +1600,7 @@ let run_file src_path =
       ~keep_builtins:true
       ~inherit_fields:true
       ~inherit_variants:true
+      ~tags
       src_path
   in
   let full_module = Atd.Ast.use_only_specific_variants full_module in

atdcpp/src/lib/Codegen.mli

@@ -4,4 +4,4 @@
 
 (** Take ATD type definitions and translate them to C++, writing
     them out to a file which should have the '.d' extension. *)
-val run_file : string -> unit
+val run_file : tags:string list -> string -> unit

atdd/src/bin/Atdd_main.ml

@@ -7,6 +7,7 @@ open Cmdliner
 
 type conf = {
   input_files: string list;
+  tags: string list;
   version: bool;
 }
 
@@ -18,7 +19,7 @@ let run conf =
   else
     conf.input_files
     |> List.iter (fun atd_file ->
-      Atdd.Codegen.run_file atd_file
+      Atdd.Codegen.run_file ~tags:conf.tags atd_file
     )
 
 (***************************************************************************)
@@ -38,6 +39,13 @@ let input_files_term =
   let default = [] in
   Arg.value (Arg.pos_all Arg.file default info)
 
+let tags_term =
+  let info =
+    Arg.info ["tag"]
+      ~doc:"Only evaluate annotations which have either the provided TAG as a field value <... tag=TAG>, or have no tags specified.\nOption can be used multiple times to specify several tags"
+  in
+  Arg.value (Arg.opt_all Arg.string [] info)
+
 let version_term =
   let info =
     Arg.info ["version"]
@@ -94,14 +102,16 @@ type bar = [
 ]
 
 let cmdline_term run =
-  let combine input_files version =
+  let combine input_files tags version =
     run {
       input_files;
       version;
+      tags;
     }
   in
   Term.(const combine
         $ input_files_term
+        $ tags_term
         $ version_term
        )
 

atdd/src/lib/Codegen.ml

@@ -32,6 +32,12 @@ let annot_schema_dlang : Atd.Annot.schema_section =
       Type_expr, "wrap";
       Field, "default";
       Module_head, "import";
+      Module_head, "tag";
+      Type_def, "tag";
+      Type_expr, "tag";
+      Variant, "tag";
+      Cell, "tag";
+      Field, "tag";
     ]
   }
 
@@ -1126,7 +1132,7 @@ let to_file ~atd_filename ~head (items : A.module_body) dst_path =
   |> double_spaced
   |> Indent.to_file ~indent:4 dst_path
 
-let run_file src_path =
+let run_file ~tags src_path =
   let src_name = Filename.basename src_path in
   let dst_name =
     (if Filename.check_suffix src_name ".atd" then
@@ -1143,6 +1149,7 @@ let run_file src_path =
       ~keep_builtins:true
       ~inherit_fields:true
       ~inherit_variants:true
+      ~tags
       src_path
   in
   let full_module = Atd.Ast.use_only_specific_variants full_module in

atdd/src/lib/Codegen.mli

@@ -4,4 +4,4 @@
 
 (** Take ATD type definitions and translate them to Dlang, writing
     them out to a file which should have the '.d' extension. *)
-val run_file : string -> unit
+val run_file : tags:string list -> string -> unit

atddiff/src/lib/Atddiff.ml

@@ -52,6 +52,7 @@ let compare_files
     |> Atd.Util.load_file
       ~inherit_fields:true (* simplifies comparison *)
       ~inherit_variants:true (* simplifies comparison *)
+      ~tags:[]
     |> fst
     |> Atd.Ast.remove_wrap_constructs
   in

atdgen/bin/ag_main.ml

@@ -71,6 +71,10 @@ let main () =
     let l = Re.Str.split (Re.Str.regexp " *, *\\| +") s in
     opens := List.rev_append l !opens
   in
+  let tags = ref [] in
+  let add_tags t =
+    tags := List.rev_append t !tags
+  in
   let pp_convs : Ocaml.pp_convs ref = ref (Ocaml.Ppx_deriving []) in
   let set_pp_convs arg =
     match !pp_convs with
@@ -104,6 +108,14 @@ let main () =
          Insert '[@@ATTR]' after OCaml type definitions.
          Option can be used multiple times to specify several attributes
     ";
+    "-tag", Arg.String (fun s -> add_tags [ s ]),
+    "
+    TAG
+         Only evaluate annotations which have either 
+          - the provided TAG as a field value <... tag=TAG>,
+          - or have no tags specified.
+         Option can be used multiple times to specify several tags
+    ";
     "-t", Arg.Unit (fun () ->
                       set_once "output type" mode T;
                       set_once "no function definitions" with_fundefs false),
@@ -422,6 +434,7 @@ Recommended usage: %s (-t|-b|-j|-v|-dep|-list|-mel) example.atd" Sys.argv.(0) in
           ~type_aliases
           ~force_defaults
           ~ocaml_version
+          ~tags:!tags
           atd_file ocaml_prefix
 
 let () =

atdgen/src/biniou.ml

@@ -41,6 +41,12 @@ let annot_schema_biniou : Atd.Annot.schema = [
     section = "biniou";
     fields = [
       Type_expr, "repr";
+      Module_head, "tag";
+      Type_def, "tag";
+      Type_expr, "tag";
+      Variant, "tag";
+      Cell, "tag";
+      Field, "tag";
     ]
   };
   {
@@ -50,6 +56,12 @@ let annot_schema_biniou : Atd.Annot.schema = [
       Type_def, "module";
       Type_def, "predef";
       Type_def, "t";
+      Module_head, "tag";
+      Type_def, "tag";
+      Type_expr, "tag";
+      Variant, "tag";
+      Cell, "tag";
+      Field, "tag";
     ]
   };
 ]