diff --git a/src/ast-check/ast_check.ml b/src/ast-check/ast_check.ml index ee49e88..21584ac 100644 --- a/src/ast-check/ast_check.ml +++ b/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 = { diff --git a/src/ast-check/ast_check.mli b/src/ast-check/ast_check.mli index ab69739..5c3636e 100644 --- a/src/ast-check/ast_check.mli +++ b/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. *) diff --git a/src/ast-check/ast_check_ppx.ml b/src/ast-check/ast_check_ppx.ml new file mode 100644 index 0000000..3fbedc3 --- /dev/null +++ b/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) diff --git a/src/ast-check/dune b/src/ast-check/dune index 72394a6..d6709f8 100644 --- a/src/ast-check/dune +++ b/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))