ast check: add ppx for ast checker

src/ast-check/ast_check.ml

@@ -14,23 +14,34 @@ module Messages = struct
   let tail_mod_cons =
     "This is a use of the 'Tail Modulo Constructor' \
      program transformation, which is not permitted"
-  let other = "The use of this feature is not permitted"
 end
 
 module Feature = struct
   type t =
     Array | Mutable_member | Object | Loop
-    | Primitive | Internal_name | Tail_mod_cons | Other
+    | Primitive | Internal_name | Tail_mod_cons
+
+  let identifiers = [
+    Array, "array";
+    Mutable_member, "mutable_member";
+    Object, "object";
+    Loop, "loop";
+    Primitive, "primitive";
+    Internal_name, "internal_name";
+    Tail_mod_cons, "tail_mod_cons";
+  ]
+
+  let to_identifier feature = List.assoc feature identifiers
+  let of_identifier ident = List.find (fun (_, id) -> ident = id) identifiers |> fst
 
   (* TODO: add TMC to AST-checker tests (needs executable to support flags) *)
-  (* TODO: remove Other? *)
 
   module Set = Set.Make (struct type nonrec t = t let compare = compare end)
 
   let all =
     Set.of_list
       [ Array; Mutable_member; Object; Loop;
-        Primitive; Internal_name; Tail_mod_cons; Other ]
+        Primitive; Internal_name; Tail_mod_cons ]
 
   let minimum = Set.of_list [ Primitive; Internal_name ]
   let default = Set.remove Tail_mod_cons all
@@ -45,7 +56,6 @@ module Feature = struct
     | Primitive -> primitive
     | Internal_name -> internal_name
     | Tail_mod_cons -> tail_mod_cons
-    | Other -> other
 end
 
 type violation = {

src/ast-check/ast_check.mli

@@ -32,9 +32,16 @@ module Feature :
   sig
     type t =
       Array | Mutable_member | Object | Loop
-      | Primitive | Internal_name | Tail_mod_cons | Other
+      | Primitive | Internal_name | Tail_mod_cons
     module Set : Set.S with type elt = t
 
+    val to_identifier : t -> string
+    (** Unique identifier for this feature. *)
+
+    val of_identifier : string -> t
+    (** Provides the feature corresponding to a unique identifier
+        returned by {!to_identifier}. *)
+
     val minimum : Set.t
     (** {!Primitive} and {!Internal_name}, required to
         prevent circumventing restrictions. *)

src/ast-check/ast_check_ppx.ml

@@ -0,0 +1,58 @@
+(** Use the AST check as a PPX rewriter, with arguments.
+    If further customization is needed, it's best to define a PPX
+    directly in the given exercise's repository instead. *)
+
+open Ppxlib.Driver
+open Ppxlib.Driver.V2
+open Ast_check
+
+let feature_identifiers =
+  Feature.all |> Feature.Set.to_list |> List.map Feature.to_identifier
+
+let prohibited_features = ref Feature.default
+
+let update_feature ~prohibit ident =
+  let open Feature in
+  prohibited_features :=
+    (if prohibit then Set.add else Set.remove)
+      (of_identifier ident) !prohibited_features
+
+let feature_spec ~prohibit =
+  Arg.Symbol (feature_identifiers, update_feature ~prohibit)
+
+let violation_limit = ref None
+
+let strip_signatures = ref false
+
+let () =
+  add_arg "-prohibit-feature"
+    (feature_spec ~prohibit:true)
+    ~doc:" Prohibit the given feature";
+  add_arg "-allow-feature"
+    (feature_spec ~prohibit:false)
+    ~doc:" Allow the given feature";
+  add_arg "-violation-limit"
+    (Arg.Int (fun l -> violation_limit := Some l))
+    ~doc:" Maximum number of violations to report";
+  add_arg "-no-violation-limit"
+    (Arg.Unit (fun () -> violation_limit := None))
+    ~doc:" Do not limit the number of reported violations (default)";
+
+  (* While the generated PPX has an argument to disable transformations,
+     there is no way to disable a transformation by default.
+     Therefore, we implement our own disabled-by-default behaviour. *)
+  add_arg "-strip-signatures"
+    (Arg.Set strip_signatures)
+    ~doc:"Enable the signature stripping transformation";
+  add_arg "-no-strip-signatures"
+    (Arg.Clear strip_signatures)
+    ~doc:"Disable the signature stripping transformation (default)";
+
+  register_transformation "ast_check"
+    ~impl:(fun ctx ->
+      Ast_check.ast_violations_transformation
+        ~prohibited:!prohibited_features ?limit:!violation_limit ctx);
+
+  register_transformation "strip_signatures"
+    ~impl:(fun ctx ast ->
+      if !strip_signatures then Ast_check.strip_signatures ctx ast else ast)

src/ast-check/dune

@@ -1,8 +1,7 @@
 (library
  (name ast_check)
  (public_name less-power.ast-check)
- (modules
-  (:standard \ ast_check_bin))
+ (modules ast_check)
  (libraries
   common
   fmt
@@ -20,3 +19,10 @@
  (package less-power)
  (modules ast_check_bin)
  (libraries common ast_check fmt))
+
+(library
+ (name ast_check_ppx)
+ (public_name less-power.ast-check-ppx)
+ (kind ppx_rewriter)
+ (modules ast_check_ppx)
+ (libraries ppxlib ast_check))