From c612ee3e66af2b3e2c2d198c3ac60f8c16217799 Mon Sep 17 00:00:00 2001 From: saroupille Date: Sun, 5 May 2024 15:08:12 +0200 Subject: [PATCH] Bam/PPX: First version of a PPX deriving Bam generators --- .github/workflows/build.yml | 2 +- bam-ppx.opam | 34 ++ dune-project | 44 ++- lib_ppx/attributes.ml | 232 ++++++++++++ lib_ppx/attributes.mli | 20 ++ lib_ppx/bam_ppx.ml | 14 + lib_ppx/deriver.ml | 333 ++++++++++++++++++ lib_ppx/deriver.mli | 7 + lib_ppx/dune | 10 + lib_ppx/helpers.ml | 54 +++ lib_ppx/helpers.mli | 5 + lib_ppx/limits.ml | 77 ++++ lib_ppx/runtime.ml | 193 ++++++++++ lib_ppx/runtime.mli | 11 + lib_ppx/ty.ml | 61 ++++ lib_ppx/ty.mli | 31 ++ test/dune | 4 +- test/main.ml | 1 + test/ppx.ml | 679 ++++++++++++++++++++++++++++++++++++ 19 files changed, 1804 insertions(+), 8 deletions(-) create mode 100644 bam-ppx.opam create mode 100644 lib_ppx/attributes.ml create mode 100644 lib_ppx/attributes.mli create mode 100644 lib_ppx/bam_ppx.ml create mode 100644 lib_ppx/deriver.ml create mode 100644 lib_ppx/deriver.mli create mode 100644 lib_ppx/dune create mode 100644 lib_ppx/helpers.ml create mode 100644 lib_ppx/helpers.mli create mode 100644 lib_ppx/limits.ml create mode 100644 lib_ppx/runtime.ml create mode 100644 lib_ppx/runtime.mli create mode 100644 lib_ppx/ty.ml create mode 100644 lib_ppx/ty.mli create mode 100644 test/ppx.ml diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 4a58c55..2846d9d 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -13,7 +13,7 @@ jobs: matrix: ocaml-compiler: [ # OCaml LTS version - ocaml.4.14.1, + ocaml.4.14.2, # ocaml-system for Fedora 39 ocaml.5.0.0, # ocaml-system for Archlinux diff --git a/bam-ppx.opam b/bam-ppx.opam new file mode 100644 index 0000000..d22c696 --- /dev/null +++ b/bam-ppx.opam @@ -0,0 +1,34 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "A PPX deriving generators for OCaml types" +description: + "Provides a way to automatically get generators for a given type" +maintainer: ["François Thiré"] +authors: ["François Thiré"] +license: "MIT" +tags: ["test" "pbt" "shrinking" "internal" "bam" "ppx"] +homepage: "https://github.com/francoisthire/bam" +doc: "https://francoisthire.github.io/bam/" +bug-reports: "https://github.com/francoisthire/bam/issues" +depends: [ + "ocaml" + "dune" {>= "3.7"} + "ppxlib" + "dmap" + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/francoisthire/bam.git" diff --git a/dune-project b/dune-project index 6ea7e08..8428177 100644 --- a/dune-project +++ b/dune-project @@ -7,9 +7,9 @@ (source (github francoisthire/bam)) -(authors "François Thiré") +(authors "Fran\195\167ois Thir\195\169") -(maintainers "François Thiré") +(maintainers "Fran\195\167ois Thir\195\169") (license MIT) @@ -18,18 +18,50 @@ (package (name bam) (synopsis "A property-based testing library with internal shrinking") - (description "A property-based testing allowing to define generators with internal shrinking easily") - (depends (ocaml (>= 4.14)) (dune (>= 3.7)) pringo (zarith (>= 1.13)) (odoc :with-doc) (tezt :with-test)) + (description + "A property-based testing allowing to define generators with internal shrinking easily") + (depends + (ocaml + (>= 4.14)) + (dune + (>= 3.7)) + pringo + (zarith + (>= 1.13)) + (odoc :with-doc) + (tezt :with-test)) (tags (test pbt shrinking internal))) +(package + (name bam-ppx) + (synopsis "A PPX deriving generators for OCaml types") + (description + "Provides a way to automatically get generators for a given type") + (depends + ocaml + dune + (ppxlib + (<= 0.32.0)) + (dmap + (>= 0.5)) + (odoc :with-doc)) + (tags + (test pbt shrinking internal bam ppx))) + (package (name tezt-bam) (synopsis "A plugin of [bam] for Tezt") (description "Provides a way to register PBT tests with Tezt") - (depends ocaml dune tezt bam (mtime (>= 2.0)) (odoc :with-doc)) + (depends + ocaml + dune + tezt + bam + (mtime + (>= 2.0)) + (odoc :with-doc)) (tags (test tezt pbt shrinking internal bam))) - ; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project diff --git a/lib_ppx/attributes.ml b/lib_ppx/attributes.ml new file mode 100644 index 0000000..4a5da0f --- /dev/null +++ b/lib_ppx/attributes.ml @@ -0,0 +1,232 @@ +open Ppxlib +include Attribute +open Runtime +open Ty + +module State_monad = struct + type ('node, 'state) t = 'node -> 'state -> 'node * 'state + + module Syntax = struct + let ( let* ) x f ct state = + let ct, state = x ct state in + f () ct state + + let return ct state = (ct, state) + end +end + +let get_attribute attribute node runtime = + match Attribute.consume_res attribute node with + | Error _ -> + (node, runtime) + | Ok (Some (ct, attribute)) -> + (ct, attribute runtime) + | Ok None -> + (node, runtime) + +let update : + ('node, 'state -> 'state) Attribute.t list -> ('node, 'state) State_monad.t + = + fun attributes -> + let open State_monad.Syntax in + let base node runtime = (node, runtime) in + List.fold_left + (fun acc attr -> + let* () = acc in + let* () = get_attribute attr in + return ) + base attributes + +module Generic : sig + (* This module declares a set of attributes that can be included at any context. Any of those attributes can modify the runtime environment. *) + val attributes : + 'node Context.t -> ('node, Runtime.t -> Runtime.t) Attribute.t list +end = struct + let min context = + Attribute.declare "gen.min" context + Ast_pattern.(single_expr_payload (eint __)) + (fun min runtime -> + {runtime with limits= {runtime.limits with min= Some min}} ) + + let max context = + Attribute.declare "gen.max" context + Ast_pattern.(single_expr_payload (eint __)) + (fun max runtime -> + {runtime with limits= {runtime.limits with max= Some max}} ) + + let int_min context = + Attribute.declare "gen.int.min" context + Ast_pattern.(single_expr_payload (eint __)) + (fun min runtime -> + { runtime with + limits= + { runtime.limits with + ranged_min= Ranged_dmap.add Int min runtime.limits.ranged_min } } + ) + + let int_max context = + Attribute.declare "gen.int.max" context + Ast_pattern.(single_expr_payload (eint __)) + (fun max runtime -> + { runtime with + limits= + { runtime.limits with + ranged_max= Ranged_dmap.add Int max runtime.limits.ranged_max } } + ) + + let int32_min context = + Attribute.declare "gen.int32.min" context + Ast_pattern.(single_expr_payload (eint32 __)) + (fun min runtime -> + { runtime with + limits= + { runtime.limits with + ranged_min= Ranged_dmap.add Int32 min runtime.limits.ranged_min } + } ) + + let int32_max context = + Attribute.declare "gen.int32.max" context + Ast_pattern.(single_expr_payload (eint32 __)) + (fun max runtime -> + { runtime with + limits= + { runtime.limits with + ranged_max= Ranged_dmap.add Int32 max runtime.limits.ranged_max } + } ) + + let int64_min context = + Attribute.declare "gen.int64.min" context + Ast_pattern.(single_expr_payload (eint64 __)) + (fun min runtime -> + { runtime with + limits= + { runtime.limits with + ranged_min= Ranged_dmap.add Int64 min runtime.limits.ranged_min } + } ) + + let int64_max context = + Attribute.declare "gen.int64.max" context + Ast_pattern.(single_expr_payload (eint64 __)) + (fun max runtime -> + { runtime with + limits= + { runtime.limits with + ranged_max= Ranged_dmap.add Int64 max runtime.limits.ranged_max } + } ) + + let size_min context = + Attribute.declare "gen.size.min" context + Ast_pattern.(single_expr_payload (eint __)) + (fun size_min runtime -> + { runtime with + limits= {runtime.limits with size_min= Some (Int.max 0 size_min)} } ) + + let size_max context = + Attribute.declare "gen.size.max" context + Ast_pattern.(single_expr_payload (eint __)) + (fun size_max runtime -> + {runtime with limits= {runtime.limits with size_max= Some size_max}} ) + + let string_size_min context = + Attribute.declare "gen.string.size.min" context + Ast_pattern.(single_expr_payload (eint __)) + (fun size_min runtime -> + { runtime with + limits= + { runtime.limits with + sized_min= + Sized_map.add (E String) (Int.max 0 size_min) + runtime.limits.sized_min } } ) + + let string_size_max context = + Attribute.declare "gen.string.size.max" context + Ast_pattern.(single_expr_payload (eint __)) + (fun size_max runtime -> + { runtime with + limits= + { runtime.limits with + sized_max= + Sized_map.add (E String) (Int.max 0 size_max) + runtime.limits.sized_max } } ) + + let overrides = + [ ("unit", E Unit) + ; ("bool", E Bool) + ; ("char", E Char) + ; ("int", E (Ranged Int)) + ; ("int32", E (Ranged Int32)) + ; ("int64", E (Ranged Int64)) + ; ("string", E (Sized String)) + ; ("bytes", E (Sized Bytes)) + ; ("list", E (Sized List)) + ; ("array", E (Sized Array)) + ; ("seq", E (Sized Seq)) + ; ("option", E Option) + ; ("any", E Any) ] + + let gen_override context (name, ty) = + Attribute.declare ("gen." ^ name) context + Ast_pattern.(single_expr_payload __) + (fun gen runtime -> + {runtime with override= Ty.Map.add ty gen runtime.override} ) + + let gen_overrides context = overrides |> List.map (gen_override context) + + let gen context = + Attribute.declare "gen.gen" context + Ast_pattern.(single_expr_payload __) + (fun gen runtime -> {runtime with gen= Some gen}) + + let attributes context = + [ min context + ; max context + ; int_min context + ; int_max context + ; int32_min context + ; int32_max context + ; int64_min context + ; int64_max context + ; size_min context + ; size_max context + ; string_size_min context + ; string_size_max context + ; gen context ] + @ gen_overrides context +end + +module Type_declaration : sig + val update : (type_declaration, Runtime.t) State_monad.t +end = struct + let attributes = Generic.attributes Attribute.Context.type_declaration + + let update = update attributes +end + +module Label_declaration : sig + val update : (label_declaration, Runtime.t) State_monad.t +end = struct + let attributes = Generic.attributes Attribute.Context.label_declaration + + let update = update attributes +end + +module Constructor_declaration : sig + val update : (constructor_declaration, Runtime.t) State_monad.t +end = struct + let attributes = Generic.attributes Attribute.Context.constructor_declaration + + let weight = + Attribute.declare "gen.weight" Attribute.Context.constructor_declaration + Ast_pattern.(single_expr_payload (eint __)) + (fun weight runtime -> {runtime with weight= Some weight}) + + let update = update (weight :: attributes) +end + +module Core_type : sig + val update : (core_type, Runtime.t) State_monad.t +end = struct + let attributes = Generic.attributes Attribute.Context.core_type + + let update = update attributes +end diff --git a/lib_ppx/attributes.mli b/lib_ppx/attributes.mli new file mode 100644 index 0000000..31b588c --- /dev/null +++ b/lib_ppx/attributes.mli @@ -0,0 +1,20 @@ +open Ppxlib + +include module type of Attribute + +module Core_type : sig + val update : core_type -> Runtime.t -> core_type * Runtime.t +end + +module Label_declaration : sig + val update : label_declaration -> Runtime.t -> label_declaration * Runtime.t +end + +module Constructor_declaration : sig + val update : + constructor_declaration -> Runtime.t -> constructor_declaration * Runtime.t +end + +module Type_declaration : sig + val update : type_declaration -> Runtime.t -> type_declaration * Runtime.t +end diff --git a/lib_ppx/bam_ppx.ml b/lib_ppx/bam_ppx.ml new file mode 100644 index 0000000..1f288dc --- /dev/null +++ b/lib_ppx/bam_ppx.ml @@ -0,0 +1,14 @@ +open Ppxlib + +let deriving_str_type_declaration ~ctxt:_ (rec_flag, type_declarations) = + Deriver.derive_type_declarations rec_flag type_declarations + +let str_type_decl = + Deriving.Generator.V2.make_noarg deriving_str_type_declaration + +let deriving_str_module_type_decl = Deriver.derive_module_type_declaration + +let str_module_type_decl = + Deriving.Generator.V2.make_noarg deriving_str_module_type_decl + +let deriver = Deriving.add "gen" ~str_type_decl ~str_module_type_decl diff --git a/lib_ppx/deriver.ml b/lib_ppx/deriver.ml new file mode 100644 index 0000000..f45a037 --- /dev/null +++ b/lib_ppx/deriver.ml @@ -0,0 +1,333 @@ +open Ppxlib + +type env = {recursive_types: string list; runtime: Runtime.t} + +let loc = !Ast_helper.default_loc + +let gen_name ident = match ident with "t" -> "gen" | _ -> "gen_" ^ ident + +let derive_type_variable ident = Ast_builder.Default.evar ~loc (gen_name ident) + +let rec derive_core_type env core_type = + let core_type, runtime = Attributes.Core_type.update core_type env.runtime in + let env = {env with runtime} in + match core_type with + | [%type: unit] -> + Runtime.get runtime Unit + | [%type: bool] | [%type: Bool.t] -> + Runtime.get runtime Bool + | [%type: char] | [%type: Char.t] -> + Runtime.get runtime Char + | [%type: int] | [%type: Int.t] -> + Runtime.get runtime (Ranged Int) + | [%type: int32] | [%type: Int32.t] -> + Runtime.get runtime (Ranged Int32) + | [%type: int64] | [%type: Int64.t] -> + Runtime.get runtime (Ranged Int64) + | [%type: string] | [%type: String.t] -> + Runtime.get runtime (Sized String) + | [%type: bytes] | [%type: Bytes.t] -> + Runtime.get runtime (Sized Bytes) + | [%type: [%t? ty] option] | [%type: [%t? ty] Option.t] -> + let env = {env with runtime= {env.runtime with gen= None}} in + let gen_ty = derive_core_type env ty in + Runtime.get runtime Option gen_ty + | [%type: [%t? ty] list] | [%type: [%t? ty] List.t] -> + let env = {env with runtime= {env.runtime with gen= None}} in + let gen_ty = derive_core_type env ty in + Runtime.get runtime (Sized List) gen_ty + | [%type: [%t? ty] array] | [%type: [%t? ty] Array.t] -> + let env = {env with runtime= {env.runtime with gen= None}} in + let gen_ty = derive_core_type env ty in + Runtime.get runtime (Sized Array) gen_ty + | [%type: [%t? ty] Seq.t] -> + let env = {env with runtime= {env.runtime with gen= None}} in + let gen_ty = derive_core_type env ty in + Runtime.get runtime (Sized Seq) gen_ty + | {ptyp_desc= Ptyp_tuple tuple; _} -> + derive_tuple env tuple `Core_type + | {ptyp_desc= Ptyp_constr ({txt= Lident ident; _}, type_args); _} -> + derive_type_constr env ident type_args + | {ptyp_desc= Ptyp_var ident; _} -> + derive_type_variable ident + | _ -> + Runtime.get runtime Any + +(* post_process is used when the tuple is declared within a variant. In that + case, the constructor identifier must prefix the tuple. *) +and derive_tuple env tuple from = + let vars = + tuple |> List.mapi (fun i _label_declaration -> "arg_" ^ string_of_int i) + in + let gens = List.map (derive_core_type env) tuple in + let base = + vars + |> List.map (fun name -> Ast_builder.Default.evar ~loc name) + |> Ast_builder.Default.pexp_tuple ~loc + |> fun tuple_expr -> + match from with + | `Constructor constructor_name -> + let expr = match tuple with [] -> None | _ -> Some tuple_expr in + [%expr + return + [%e Ast_builder.Default.pexp_construct ~loc constructor_name expr]] + | `Core_type -> + [%expr return [%e tuple_expr]] + in + List.fold_left2 + (fun expr var gen -> + let name = Ast_builder.Default.pvar ~loc var in + [%expr + let* [%p name] = [%e gen] in + [%e expr]] ) + base (List.rev vars) (List.rev gens) + +and derive_type_constr env ident args = + let args = + List.map + (fun arg -> + let env = {env with runtime= {env.runtime with gen= None}} in + derive_core_type env arg ) + args + in + let f = + match env.runtime.gen with + | None -> + Ast_builder.Default.evar ~loc (gen_name ident) + | Some gen -> + gen + in + if List.mem ident env.recursive_types then + (* If the recursive type does not take any type parameter, the generators + code might not be a value which is an issue in case of recursive values. We + wrap them with a unit argument. *) + Ast_builder.Default.eapply ~loc f (Ast_builder.Default.eunit ~loc :: args) + else Ast_builder.Default.eapply ~loc f args + +let derive_manifest env = function + | None -> + Runtime.get env.runtime Any + | Some core_type -> + derive_core_type env core_type + +let derive_label_declaration env label_declaration = + let label_declaration, runtime = + Attributes.Label_declaration.update label_declaration env.runtime + in + let env = {env with runtime} in + match env.runtime.gen with + | None -> + derive_core_type env label_declaration.pld_type + | Some gen -> + gen + +let derive_record env record from = + let base = + record + |> List.map (fun label_declaration -> + let location = + Astlib.Location. + {txt= Astlib.Longident.parse label_declaration.pld_name.txt; loc} + in + let expression = + Ast_builder.Default.evar ~loc label_declaration.pld_name.txt + in + (location, expression) ) + |> fun fields -> + Ast_builder.Default.pexp_record ~loc fields None + |> fun record_expr -> + match from with + | `Constructor constructor_name -> + let expr = match record with [] -> None | _ -> Some record_expr in + [%expr + return + [%e Ast_builder.Default.pexp_construct ~loc constructor_name expr]] + | `Type_declaration -> + [%expr return [%e record_expr]] + in + List.fold_left + (fun expr label_declaration -> + let body = derive_label_declaration env label_declaration in + let name = Ast_builder.Default.pvar ~loc label_declaration.pld_name.txt in + [%expr + let* [%p name] = [%e body] in + [%e expr]] ) + base (List.rev record) + +let derive_constructor_declaration env constructor_declaration = + let constructor_declaration, runtime = + Attributes.Constructor_declaration.update constructor_declaration + env.runtime + in + let env = {env with runtime} in + let weight = Option.value ~default:1 env.runtime.weight in + match env.runtime.gen with + | Some gen -> + (weight, gen) + | None -> ( + let constructor_name = + {txt= Astlib.Longident.parse constructor_declaration.pcd_name.txt; loc} + in + let from = `Constructor constructor_name in + match constructor_declaration.pcd_args with + | Pcstr_tuple tuple -> + (weight, derive_tuple env tuple from) + | Pcstr_record record -> + (weight, derive_record env record from) ) + +let derive_variant env constructors = + match constructors with + | [x] -> + derive_constructor_declaration env x |> snd + | _ -> + let constructors = List.rev constructors in + let names = + constructors |> List.map (fun {pcd_name; _} -> gen_name pcd_name.txt) + in + let weights, constructors_expr = + constructors + |> List.map (derive_constructor_declaration env) + |> List.split + in + let base = + let names = List.map (Ast_builder.Default.evar ~loc) (List.rev names) in + let weights = + List.map (Ast_builder.Default.eint ~loc) (List.rev weights) + in + let weighted_list = + List.map2 + (fun weight name -> + Ast_builder.Default.pexp_tuple ~loc [weight; name] ) + weights names + in + let expr = Ast_builder.Default.elist ~loc weighted_list in + [%expr Bam.Std.oneof [%e expr]] + in + List.fold_left2 + (fun expr name body -> + let name = Ast_builder.Default.pvar ~loc name in + [%expr + let [%p name] = [%e body] in + [%e expr]] ) + base names constructors_expr + +let derive_type_declaration env type_declaration = + let type_declaration, runtime = + Attributes.Type_declaration.update type_declaration env.runtime + in + let env = {env with runtime} in + match env.runtime.gen with + | Some gen -> + gen + | None -> + let ct = core_type_of_type_declaration type_declaration in + let expected_type = [%type: [%t ct] Bam.Gen.t] in + let body = + match type_declaration.ptype_kind with + | Ptype_abstract -> + derive_manifest env type_declaration.ptype_manifest + | Ptype_record record -> + derive_record env record `Type_declaration + | Ptype_variant variant -> + derive_variant env variant + | Ptype_open -> + Runtime.get env.runtime Any + in + let td = name_type_params_in_td type_declaration in + let params = + td.ptype_params + |> List.filter_map (fun (param, _variance) -> + match param with + | {ptyp_desc= Ptyp_var ident; _} -> + Some ident + | _ -> + None ) + |> List.filter (Fun.flip Helpers.is_type_var_used td) + |> List.map (fun ident -> + Ast_builder.Default.pvar ~loc (gen_name ident) ) + in + (* This can be used for debugging when modifying the deriver to ensure its correctness. *) + let show_expected_type = false in + let base = + if show_expected_type then [%expr ([%e body] : [%t expected_type])] + else body + in + List.fold_left + (fun expr ident -> [%expr fun [%p ident] -> [%e expr]]) + base (List.rev params) + +let derive_type_declarations rec_flag type_declarations : + Ast.structure_item list = + let loc = !Ast_helper.default_loc in + let is_recursive = really_recursive rec_flag type_declarations in + let env = + { recursive_types= + type_declarations |> List.map (fun td -> td.ptype_name.txt) + ; runtime= Runtime.default } + in + let bindings = + type_declarations + |> List.map (fun td -> + let name = td.ptype_name.txt in + let generator_name = + let raw = gen_name name in + Ast_builder.Default.pvar ~loc raw + in + let gen_expr = derive_type_declaration env td in + let gen_expr = + if is_recursive = Recursive then + Ast_builder.Default.pexp_fun ~loc Nolabel None + [%pat? ()] + gen_expr + else gen_expr + in + { pvb_pat= generator_name + ; pvb_expr= gen_expr + ; pvb_attributes= [] + ; pvb_loc= loc } ) + in + Ast_builder.Default.pstr_value_list ~loc is_recursive bindings + +let derive_str_signature_item = function + | Psig_type (rec_flag, type_declarations) -> + derive_type_declarations rec_flag type_declarations + | _ -> + [] + +let derive_str_signature signature = + signature + |> List.map (fun signature_item -> + derive_str_signature_item signature_item.psig_desc ) + |> List.concat + +let derive_str_module_type = function + | Pmty_ident _ -> + [] + | Pmty_signature signature -> + derive_str_signature signature + | Pmty_functor _ -> + [] + | Pmty_with _ -> + [] + | Pmty_typeof _ -> + [] + | Pmty_extension _ -> + [] + | Pmty_alias _ -> + [] + +let derive_module_type_declaration ~ctxt:_ module_type_declaration = + match module_type_declaration.pmtd_type with + | None -> + [] + | Some module_type -> + let loc = !Ast_helper.default_loc in + let module_binding = + { pmb_name= {loc; txt= Some module_type_declaration.pmtd_name.txt} + ; pmb_expr= + Ast_builder.Default.pmod_structure ~loc + (derive_str_module_type module_type.pmty_desc) + ; pmb_attributes= [] + ; pmb_loc= loc } + in + [Ast_builder.Default.pstr_module ~loc module_binding] diff --git a/lib_ppx/deriver.mli b/lib_ppx/deriver.mli new file mode 100644 index 0000000..303e6e5 --- /dev/null +++ b/lib_ppx/deriver.mli @@ -0,0 +1,7 @@ +val derive_type_declarations : + Asttypes.rec_flag + -> Parsetree.type_declaration list + -> Parsetree.structure_item list + +val derive_module_type_declaration : + ctxt:'a -> Parsetree.module_type_declaration -> Parsetree.structure_item list diff --git a/lib_ppx/dune b/lib_ppx/dune new file mode 100644 index 0000000..3a81fec --- /dev/null +++ b/lib_ppx/dune @@ -0,0 +1,10 @@ +(library + (name bam_ppx) + (public_name bam-ppx) + (kind ppx_deriver) + (libraries ppxlib dmap) + (preprocess + (pps ppxlib.metaquot))) + +(documentation + (package bam)) diff --git a/lib_ppx/helpers.ml b/lib_ppx/helpers.ml new file mode 100644 index 0000000..be112e5 --- /dev/null +++ b/lib_ppx/helpers.ml @@ -0,0 +1,54 @@ +open Ppxlib + +let is_identifier_expr (expr : expression) : bool = + match expr.pexp_desc with Pexp_ident _ -> true | _ -> false + +let rec is_type_var_used_in_core_type var_name (ct : core_type) : bool = + match ct.ptyp_desc with + | Ptyp_var s -> + s = var_name (* Check if it matches the variable name *) + | Ptyp_arrow (_, ct1, ct2) -> + is_type_var_used_in_core_type var_name ct1 + || is_type_var_used_in_core_type var_name ct2 + | Ptyp_tuple cts -> + List.exists (is_type_var_used_in_core_type var_name) cts + | Ptyp_constr (_, args) -> + List.exists (is_type_var_used_in_core_type var_name) args + | Ptyp_alias (ct, s) -> + s = var_name || is_type_var_used_in_core_type var_name ct + | Ptyp_poly (_, ct) -> + is_type_var_used_in_core_type var_name ct + | _ -> + false + +(* Function to check if a type variable is used in a type_declaration *) +let is_type_var_used var_name (td : Parsetree.type_declaration) : bool = + let is_used_in_manifest = + match td.Parsetree.ptype_manifest with + | Some ct -> + is_type_var_used_in_core_type var_name ct + | None -> + false + in + let is_used_in_kind = + match td.Parsetree.ptype_kind with + | Parsetree.Ptype_abstract -> + is_used_in_manifest + | Parsetree.Ptype_variant constrs -> + constrs + |> List.map (fun c -> c.pcd_args) + |> List.exists (function + | Pcstr_tuple tuple -> + List.exists (is_type_var_used_in_core_type var_name) tuple + | Pcstr_record record -> + record + |> List.map (fun label -> label.pld_type) + |> List.exists (is_type_var_used_in_core_type var_name) ) + | Parsetree.Ptype_record lbls -> + List.exists + (fun l -> is_type_var_used_in_core_type var_name l.Parsetree.pld_type) + lbls + | Parsetree.Ptype_open -> + is_used_in_manifest + in + is_used_in_manifest || is_used_in_kind diff --git a/lib_ppx/helpers.mli b/lib_ppx/helpers.mli new file mode 100644 index 0000000..b417073 --- /dev/null +++ b/lib_ppx/helpers.mli @@ -0,0 +1,5 @@ +open Ppxlib + +val is_identifier_expr : expression -> bool + +val is_type_var_used : string -> type_declaration -> bool diff --git a/lib_ppx/limits.ml b/lib_ppx/limits.ml new file mode 100644 index 0000000..ddc05a3 --- /dev/null +++ b/lib_ppx/limits.ml @@ -0,0 +1,77 @@ +open Ty + +type t = + { min: int option + ; max: int option + ; size_min: int option + ; size_max: int option + ; ranged_min: Ranged_dmap.t + ; ranged_max: Ranged_dmap.t + ; sized_min: int Sized_map.t + ; sized_max: int Sized_map.t } + +let default = + { min= None + ; max= None + ; size_min= None + ; size_max= Some 10 + ; ranged_min= Ranged_dmap.empty + ; ranged_max= Ranged_dmap.empty + ; sized_min= Sized_map.empty + ; sized_max= Sized_map.empty } + +let int_min limits = + match Ranged_dmap.find_opt Int limits.ranged_min with + | None -> + limits.min + | Some i -> + Some i + +let int_max limits = + match Ranged_dmap.find_opt Int limits.ranged_max with + | None -> + limits.max + | Some i -> + Some i + +let int32_min limits = + match Ranged_dmap.find_opt Int32 limits.ranged_min with + | None -> + limits.min |> Option.map Int32.of_int + | Some i -> + Some i + +let int32_max limits = + match Ranged_dmap.find_opt Int32 limits.ranged_max with + | None -> + limits.max |> Option.map Int32.of_int + | Some i -> + Some i + +let int64_min limits = + match Ranged_dmap.find_opt Int64 limits.ranged_min with + | None -> + limits.min |> Option.map Int64.of_int + | Some i -> + Some i + +let int64_max limits = + match Ranged_dmap.find_opt Int64 limits.ranged_max with + | None -> + limits.max |> Option.map Int64.of_int + | Some i -> + Some i + +let sized_min limits sized = + match Sized_map.find_opt sized limits.sized_min with + | None -> + limits.size_min + | Some i -> + Some i + +let sized_max limits sized = + match Sized_map.find_opt sized limits.sized_max with + | None -> + limits.size_max + | Some i -> + Some i diff --git a/lib_ppx/runtime.ml b/lib_ppx/runtime.ml new file mode 100644 index 0000000..013160d --- /dev/null +++ b/lib_ppx/runtime.ml @@ -0,0 +1,193 @@ +open Ppxlib + +let loc = !Ast_helper.default_loc + +module Default = struct + let unit = [%expr Bam.Std.return ()] + + let bool = [%expr Bam.Std.bool ()] + + let int ~min ~max () = + let min = Option.map (Ast_builder.Default.eint ~loc) min in + let max = Option.map (Ast_builder.Default.eint ~loc) max in + match (min, max) with + | None, None -> + [%expr Bam.Std.int ()] + | Some min, None -> + [%expr Bam.Std.int ~min:[%e min] ()] + | None, Some max -> + [%expr Bam.Std.int ~max:[%e max] ()] + | Some min, Some max -> + [%expr Bam.Std.int ~min:[%e min] ~max:[%e max] ()] + + let int32 ~min ~max () = + let min = Option.map (Ast_builder.Default.eint32 ~loc) min in + let max = Option.map (Ast_builder.Default.eint32 ~loc) max in + match (min, max) with + | None, None -> + [%expr Bam.Std.int32 ()] + | Some min, None -> + [%expr Bam.Std.int32 ~min:[%e min] ()] + | None, Some max -> + [%expr Bam.Std.int32 ~max:[%e max] ()] + | Some min, Some max -> + [%expr Bam.Std.int32 ~min:[%e min] ~max:[%e max] ()] + + let int64 ~min ~max () = + let min = Option.map (Ast_builder.Default.eint64 ~loc) min in + let max = Option.map (Ast_builder.Default.eint64 ~loc) max in + match (min, max) with + | None, None -> + [%expr Bam.Std.int64 ()] + | Some min, None -> + [%expr Bam.Std.int64 ~min:[%e min] ()] + | None, Some max -> + [%expr Bam.Std.int64 ~max:[%e max] ()] + | Some min, Some max -> + [%expr Bam.Std.int64 ~min:[%e min] ~max:[%e max] ()] + + let char () = [%expr Bam.Std.char ()] + + let string ~size_min ~size_max () = + let size = int ~min:size_min ~max:size_max () in + [%expr Bam.Std.string ~size:[%e size] ()] + + let bytes ~size_min ~size_max () = + let size = int ~min:size_min ~max:size_max () in + [%expr Bam.Std.bytes ~size:[%e size] ()] + + let option gen = + let none = [%expr return None] in + let some = + [%expr + let* value = [%e gen] in + return (Some value)] + in + [%expr Bam.Std.oneof [(1, [%e none]); (1, [%e some])]] + + let list ~size_min ~size_max gen = + [%expr Bam.Std.list ~size:[%e int ~min:size_min ~max:size_max ()] [%e gen]] + + let array ~size_min ~size_max gen = + [%expr + let* list = [%e list ~size_min ~size_max gen] in + return (Array.of_list list)] + + let seq ~size_min ~size_max gen = + [%expr + let* list = [%e list ~size_min ~size_max gen] in + return (List.to_seq list)] +end + +let pretty_apply f a = + (* A heuristic that introduce a let in if it can make the output more + readable. *) + if Helpers.is_identifier_expr a then f a + else + let var = gen_symbol ~prefix:"gen" () in + let evar = Ast_builder.Default.evar ~loc var in + let pvar = Ast_builder.Default.pvar ~loc var in + [%expr + let [%p pvar] = [%e a] in + [%e f evar]] + +let get_default (type a) limits : a Ty.t -> a = function + | Unit -> + Default.unit + | Bool -> + Default.bool + | Char -> + Default.char () + | Ranged Int -> + let min = Limits.int_min limits in + let max = Limits.int_max limits in + Default.int ~min ~max () + | Ranged Int32 -> + let min = Limits.int32_min limits in + let max = Limits.int32_max limits in + Default.int32 ~min ~max () + | Ranged Int64 -> + let min = Limits.int64_min limits in + let max = Limits.int64_max limits in + Default.int64 ~min ~max () + | Sized String -> + let size_min = Limits.sized_min limits (E String) in + let size_max = Limits.sized_max limits (E String) in + Default.string ~size_min ~size_max () + | Sized Bytes -> + let size_min = Limits.sized_min limits (E Bytes) in + let size_max = Limits.sized_max limits (E Bytes) in + Default.bytes ~size_min ~size_max () + | Sized List -> + let size_min = Limits.sized_min limits (E List) in + let size_max = Limits.sized_max limits (E List) in + pretty_apply (Default.list ~size_min ~size_max) + | Sized Array -> + let size_min = Limits.sized_min limits (E Array) in + let size_max = Limits.sized_max limits (E Array) in + pretty_apply (Default.array ~size_min ~size_max) + | Sized Seq -> + let size_min = Limits.sized_min limits (E Seq) in + let size_max = Limits.sized_max limits (E Seq) in + pretty_apply (Default.seq ~size_min ~size_max) + | Option -> + pretty_apply Default.option + | Any -> + failwith "The 'gen' deriver could not handle this case" + +type t = + { limits: Limits.t + ; override: expression Ty.Map.t + ; gen: expression option + ; weight: int option } + +let default = + {limits= Limits.default; override= Ty.Map.empty; gen= None; weight= None} + +let get (type a) t : a Ty.t -> a = + fun ty -> + (* A generator can be overrided twice. Either by specifying a default override + for a given type, or locally by specifying a generator at the definition + point. The last one has a higher priority. *) + let override = + match t.gen with + | None -> ( + match Ty.Map.find_opt (E ty) t.override with + | None -> + None + | Some gen -> + Some gen ) + | Some gen -> + Some gen + in + match override with + | None -> + get_default t.limits ty + | Some gen -> ( + match ty with + | Unit -> + gen + | Bool -> + gen + | Char -> + gen + | Ranged Int -> + gen + | Ranged Int32 -> + gen + | Ranged Int64 -> + gen + | Sized String -> + gen + | Sized Bytes -> + gen + | Sized List -> + fun expression -> [%expr [%e gen] [%e expression]] + | Sized Array -> + fun expression -> [%expr [%e gen] [%e expression]] + | Sized Seq -> + fun expression -> [%expr [%e gen] [%e expression]] + | Option -> + fun expression -> [%expr [%e gen] [%e expression]] + | Any -> + gen ) diff --git a/lib_ppx/runtime.mli b/lib_ppx/runtime.mli new file mode 100644 index 0000000..0982e52 --- /dev/null +++ b/lib_ppx/runtime.mli @@ -0,0 +1,11 @@ +open Ppxlib + +type t = + { limits: Limits.t + ; override: expression Ty.Map.t + ; gen: expression option + ; weight: int option } + +val default : t + +val get : t -> 'continuation Ty.t -> 'continuation diff --git a/lib_ppx/ty.ml b/lib_ppx/ty.ml new file mode 100644 index 0000000..e128680 --- /dev/null +++ b/lib_ppx/ty.ml @@ -0,0 +1,61 @@ +open Ppxlib + +type _ ranged = Int : int ranged | Int32 : int32 ranged | Int64 : int64 ranged + +let ranged_compare (type a1 a2) : a1 ranged -> a2 ranged -> (a1, a2) Dmap.cmp = + fun left right -> + match (left, right) with + | Int, Int -> + Dmap.Eq + | Int32, Int32 -> + Dmap.Eq + | Int64, Int64 -> + Dmap.Eq + | Int, _ -> + Lt + | Int32, Int -> + Gt + | Int32, _ -> + Lt + | Int64, Int -> + Gt + | Int64, Int32 -> + Gt + +type 'continuation sized = + | String : expression sized + | Bytes : expression sized + | List : (expression -> expression) sized + | Array : (expression -> expression) sized + | Seq : (expression -> expression) sized + +type 'continuation t = + | Unit : expression t + | Bool : expression t + | Char : expression t + | Ranged : _ ranged -> expression t + | Sized : 'continuation sized -> 'continuation t + | Option : (expression -> expression) t + | Any : expression t + +module Ranged_dmap = Dmap.Make (struct + type 'a t = 'a ranged + + let compare = ranged_compare +end) + +type st = E : _ sized -> st + +module Sized_map = Map.Make (struct + type t = st + + let compare = compare +end) + +type et = E : _ t -> et + +module Map = Map.Make (struct + type t = et + + let compare = compare +end) diff --git a/lib_ppx/ty.mli b/lib_ppx/ty.mli new file mode 100644 index 0000000..1fa9489 --- /dev/null +++ b/lib_ppx/ty.mli @@ -0,0 +1,31 @@ +open Ppxlib + +type _ ranged = Int : int ranged | Int32 : int32 ranged | Int64 : int64 ranged + +val ranged_compare : 'a ranged -> 'b ranged -> ('a, 'b) Dmap.cmp + +type 'continuation sized = + | String : expression sized + | Bytes : expression sized + | List : (expression -> expression) sized + | Array : (expression -> expression) sized + | Seq : (expression -> expression) sized + +type 'continuation t = + | Unit : expression t + | Bool : expression t + | Char : expression t + | Ranged : _ ranged -> expression t + | Sized : 'continuation sized -> 'continuation t + | Option : (expression -> expression) t + | Any : expression t + +module Ranged_dmap : Dmap.S with type 'a key = 'a ranged + +type st = E : 'a sized -> st + +module Sized_map : Map.S with type key = st + +type et = E : 'a t -> et + +module Map : Map.S with type key = et diff --git a/test/dune b/test/dune index 14872fe..504d115 100644 --- a/test/dune +++ b/test/dune @@ -1,4 +1,6 @@ (test (name main) - (libraries tezt-bam) + (libraries tezt-bam bam-ppx) + (preprocess + (pps bam_ppx)) (package tezt-bam)) diff --git a/test/main.ml b/test/main.ml index 6e8ff9c..758d80d 100644 --- a/test/main.ml +++ b/test/main.ml @@ -5,4 +5,5 @@ let () = Gen.register () ; Std.register () ; Pbt.register () ; + Ppx.register () ; Test.run () diff --git a/test/ppx.ml b/test/ppx.ml new file mode 100644 index 0000000..aacab4c --- /dev/null +++ b/test/ppx.ml @@ -0,0 +1,679 @@ +open Bam.Std.Syntax + +type foo = int [@@deriving_inline gen] + +let _ = fun (_ : foo) -> () + +let gen_foo = Bam.Std.int () + +let _ = gen_foo + +[@@@end] + +type foo2 = string [@@deriving_inline gen] + +let _ = fun (_ : foo2) -> () + +let gen_foo2 = Bam.Std.string ~size:(Bam.Std.int ~max:10 ()) () + +let _ = gen_foo2 + +[@@@end] + +type foo3 = bool [@@deriving_inline gen] + +let _ = fun (_ : foo3) -> () + +let gen_foo3 = Bam.Std.bool () + +let _ = gen_foo3 + +[@@@end] + +type foo4 = unit [@@deriving_inline gen] + +let _ = fun (_ : foo4) -> () + +let gen_foo4 = Bam.Std.return () + +let _ = gen_foo4 + +[@@@end] + +type foo5 = char [@@deriving_inline gen] + +let _ = fun (_ : foo5) -> () + +let gen_foo5 = Bam.Std.char () + +let _ = gen_foo5 + +[@@@end] + +type foo6 = int option [@@deriving_inline gen] + +let _ = fun (_ : foo6) -> () + +let gen_foo6 = + let gen__001_ = Bam.Std.int () in + Bam.Std.oneof + [ (1, return None) + ; ( 1 + , let* value = gen__001_ in + return (Some value) ) ] + +let _ = gen_foo6 + +[@@@end] + +type foo8 = {bar1: int; bar2: foo9; bar3: string} + +and foo9 = {truc: char; bidule: foo8} [@@deriving_inline gen] + +let _ = fun (_ : foo8) -> () + +let _ = fun (_ : foo9) -> () + +let rec gen_foo8 () = + let* bar1 = Bam.Std.int () in + let* bar2 = gen_foo9 () in + let* bar3 = Bam.Std.string ~size:(Bam.Std.int ~max:10 ()) () in + return {bar1; bar2; bar3} + +and gen_foo9 () = + let* truc = Bam.Std.char () in + let* bidule = gen_foo8 () in + return {truc; bidule} + +let _ = gen_foo8 + +and _ = gen_foo9 + +[@@@end] + +type foo10 = A of int * string [@weight 100] | B [@@deriving_inline gen] + +let _ = fun (_ : foo10) -> () + +let gen_foo10 = + let gen_A = + let* arg_0 = Bam.Std.int () in + let* arg_1 = Bam.Std.string ~size:(Bam.Std.int ~max:10 ()) () in + return (A (arg_0, arg_1)) + in + let gen_B = return B in + Bam.Std.oneof [(100, gen_A); (1, gen_B)] + +let _ = gen_foo10 + +[@@@end] + +type foo11 = A of (int * string) [@gen Bam.Std.return (A (0, ""))] +[@@deriving_inline gen] + +let _ = fun (_ : foo11) -> () + +let gen_foo11 = Bam.Std.return (A (0, "")) + +let _ = gen_foo11 + +[@@@end] + +type foo12 = foo11 [@@deriving_inline gen] + +let _ = fun (_ : foo12) -> () + +let gen_foo12 = gen_foo11 + +let _ = gen_foo12 + +[@@@end] + +type ('a, 'b) foo13 = ('a * 'b) list [@@deriving_inline gen] + +let _ = fun (_ : ('a, 'b) foo13) -> () + +let gen_foo13 gen_a gen_b = + let gen__002_ = + let* arg_0 = gen_a in + let* arg_1 = gen_b in + return (arg_0, arg_1) + in + Bam.Std.list ~size:(Bam.Std.int ~max:10 ()) gen__002_ + +let _ = gen_foo13 + +[@@@end] + +type 'a check = 'a list [@@deriving_inline gen] + +let _ = fun (_ : 'a check) -> () + +let gen_check gen_a = Bam.Std.list ~size:(Bam.Std.int ~max:10 ()) gen_a + +let _ = gen_check + +[@@@end] + +type 'a test = A of 'a check | B of string [@@deriving_inline gen] + +let _ = fun (_ : 'a test) -> () + +let gen_test gen_a = + let gen_A = + let* arg_0 = gen_check gen_a in + return (A arg_0) + in + let gen_B = + let* arg_0 = Bam.Std.string ~size:(Bam.Std.int ~max:10 ()) () in + return (B arg_0) + in + Bam.Std.oneof [(1, gen_A); (1, gen_B)] + +let _ = gen_test + +[@@@end] + +type scenario = bool test list [@@deriving_inline gen] + +let _ = fun (_ : scenario) -> () + +let gen_scenario = + let gen__003_ = gen_test (Bam.Std.bool ()) in + Bam.Std.list ~size:(Bam.Std.int ~max:10 ()) gen__003_ + +let _ = gen_scenario + +[@@@end] + +type gadt = A : int -> gadt | B : string -> gadt [@@deriving_inline gen] + +let _ = fun (_ : gadt) -> () + +let gen_gadt = + let gen_A = + let* arg_0 = Bam.Std.int () in + return (A arg_0) + in + let gen_B = + let* arg_0 = Bam.Std.string ~size:(Bam.Std.int ~max:10 ()) () in + return (B arg_0) + in + Bam.Std.oneof [(1, gen_A); (1, gen_B)] + +let _ = gen_gadt + +[@@@end] + +type arr = int array [@@deriving_inline gen] + +let _ = fun (_ : arr) -> () + +let gen_arr = + let gen__004_ = Bam.Std.int () in + let* list = Bam.Std.list ~size:(Bam.Std.int ~max:10 ()) gen__004_ in + return (Array.of_list list) + +let _ = gen_arr + +[@@@end] + +let register () = () + +module Gen = struct + type key = string * int [@@deriving_inline gen] + + let _ = fun (_ : key) -> () + + let gen_key = + let* arg_0 = Bam.Std.string ~size:(Bam.Std.int ~max:10 ()) () in + let* arg_1 = Bam.Std.int () in + return (arg_0, arg_1) + + let _ = gen_key + + [@@@end] + + type value = Bytes.t [@@deriving_inline gen] + + let _ = fun (_ : value) -> () + + let gen_value = Bam.Std.bytes ~size:(Bam.Std.int ~max:10 ()) () + + let _ = gen_value + + [@@@end] + + type write_payload = {key: key; override: bool; default: bool} + [@@deriving_inline gen] + + let _ = fun (_ : write_payload) -> () + + let gen_write_payload = + let* key = gen_key in + let* override = Bam.Std.bool () in + let* default = Bam.Std.bool () in + return {key; override; default} + + let _ = gen_write_payload + + [@@@end] + + type action = + | Write_value of write_payload + | Read_value of key + | Read_values of key Seq.t + | Remove_file of string + | Count_values of string + [@@deriving_inline gen] + + let _ = fun (_ : action) -> () + + let gen_action = + let gen_Write_value = + let* arg_0 = gen_write_payload in + return (Write_value arg_0) + in + let gen_Read_value = + let* arg_0 = gen_key in + return (Read_value arg_0) + in + let gen_Read_values = + let* arg_0 = + let* list = Bam.Std.list ~size:(Bam.Std.int ~max:10 ()) gen_key in + return (List.to_seq list) + in + return (Read_values arg_0) + in + let gen_Remove_file = + let* arg_0 = Bam.Std.string ~size:(Bam.Std.int ~max:10 ()) () in + return (Remove_file arg_0) + in + let gen_Count_values = + let* arg_0 = Bam.Std.string ~size:(Bam.Std.int ~max:10 ()) () in + return (Count_values arg_0) + in + Bam.Std.oneof + [ (1, gen_Write_value) + ; (1, gen_Read_value) + ; (1, gen_Read_values) + ; (1, gen_Remove_file) + ; (1, gen_Count_values) ] + + let _ = gen_action + + [@@@end] + + type bind = Sequential | Parallel [@@deriving_inline gen] + + let _ = fun (_ : bind) -> () + + let gen_bind = + let gen_Sequential = return Sequential in + let gen_Parallel = return Parallel in + Bam.Std.oneof [(1, gen_Sequential); (1, gen_Parallel)] + + let _ = gen_bind + + [@@@end] + + type scenario = action * (bind * action) list [@@deriving_inline gen] + + let _ = fun (_ : scenario) -> () + + let gen_scenario = + let* arg_0 = gen_action in + let* arg_1 = + let gen__005_ = + let* arg_0 = gen_bind in + let* arg_1 = gen_action in + return (arg_0, arg_1) + in + Bam.Std.list ~size:(Bam.Std.int ~max:10 ()) gen__005_ + in + return (arg_0, arg_1) + + let _ = gen_scenario + + [@@@end] +end + +module type Gen3 = sig + type t = int + + type t2 = string + + type t4 = t2 +end +[@@deriving_inline gen] + +include struct + [@@@ocaml.warning "-60"] + + module Gen3 = struct + let gen = Bam.Std.int () + + let _ = gen + + let gen_t2 = Bam.Std.string ~size:(Bam.Std.int ~max:10 ()) () + + let _ = gen_t2 + + let gen_t4 = gen_t2 + + let _ = gen_t4 + end +end [@@ocaml.doc "@inline"] + +[@@@end] + +module Gen2 = struct + type key = string * int + + let gen_key = + let* arg_0 = Bam.Std.string ~size:(Bam.Std.int ~max:10 ()) () in + let* arg_1 = Bam.Std.int ~max:10 () in + return (arg_0, arg_1) + + type value = Bytes.t + + let gen_value = Bam.Std.bytes ~size:(Bam.Std.int ~max:10 ()) () + + type write_payload = {key: key; override: bool; default: bool} + + let gen_write_payload = + let* key = gen_key in + let* override = Bam.Std.bool () in + let* default = Bam.Std.bool () in + return {key; override; default} + + type action = + | Write_value of write_payload + | Read_value of key + | Read_values of key Seq.t + | Remove_file of string + | Count_values of string + + let gen_action = + let* gen_Write_value = + let* arg_0 = gen_write_payload in + return (Write_value arg_0) + in + let* gen_Read_value = + let* arg_0 = gen_key in + return (Read_value arg_0) + in + let* gen_Read_values = + let* arg_0 = + let* list = Bam.Std.list ~size:(Bam.Std.int ~max:10 ()) gen_key in + return (List.to_seq list) + in + return (Read_values arg_0) + in + let* gen_Remove_file = + let* arg_0 = Bam.Std.string ~size:(Bam.Std.int ~max:10 ()) () in + return (Remove_file arg_0) + in + let* gen_Count_values = + let* arg_0 = Bam.Std.string ~size:(Bam.Std.int ~max:10 ()) () in + return (Count_values arg_0) + in + Bam.Std.oneofl + [ gen_Write_value + ; gen_Read_value + ; gen_Read_values + ; gen_Remove_file + ; gen_Count_values ] + + let _ = gen_action + + type bind = Sequential | Parallel + + let gen_bind = + let* gen_Sequential = return Sequential in + let* gen_Parallel = return Parallel in + Bam.Std.oneofl [gen_Sequential; gen_Parallel] + + type scenario = action * (bind * action) list + + let gen_scenario = + let* arg_0 = gen_action in + let* arg_1 = + Bam.Std.list ~size:(Bam.Std.int ~max:10 ()) + (let* arg_0 = gen_bind in + let* arg_1 = gen_action in + return (arg_0, arg_1) ) + in + return (arg_0, arg_1) +end + +module type Foo = sig + type t = (int[@max 25]) +end +[@@deriving_inline gen] + +include struct + [@@@ocaml.warning "-60"] + + module Foo = struct + let gen = Bam.Std.int ~max:25 () + + let _ = gen + end +end [@@ocaml.doc "@inline"] + +[@@@end] + +type c0 = (string[@size.max 25]) * (int[@min 10] [@max 20]) +[@@deriving_inline gen] + +let _ = fun (_ : c0) -> () + +let gen_c0 = + let* arg_0 = Bam.Std.string ~size:(Bam.Std.int ~max:25 ()) () in + let* arg_1 = Bam.Std.int ~min:10 ~max:20 () in + return (arg_0, arg_1) + +let _ = gen_c0 + +[@@@end] + +type c1 = A of (int[@gen Bam.Std.int ~max:20 ()]) [@@deriving_inline gen] + +let _ = fun (_ : c1) -> () + +let gen_c1 = + let* arg_0 = Bam.Std.int ~max:20 () in + return (A arg_0) + +let _ = gen_c1 + +[@@@end] + +type c2 = int * string [@@deriving_inline gen] [@@max 20] [@@size.max 40] + +let _ = fun (_ : c2) -> () + +let gen_c2 = + let* arg_0 = Bam.Std.int ~max:20 () in + let* arg_1 = Bam.Std.string ~size:(Bam.Std.int ~max:40 ()) () in + return (arg_0, arg_1) + +let _ = gen_c2 + +[@@@end] + +type c3 = {a: (int[@max 20]); b: string} [@@deriving_inline gen] [@@min 5] + +let _ = fun (_ : c3) -> () + +let gen_c3 = + let* a = Bam.Std.int ~min:5 ~max:20 () in + let* b = Bam.Std.string ~size:(Bam.Std.int ~max:10 ()) () in + return {a; b} + +let _ = gen_c3 + +[@@@end] + +type c4 = {a: (int[@min 20] [@size.min 40] [@int.min 30]); b: string} +[@@deriving_inline gen] + +let _ = fun (_ : c4) -> () + +let gen_c4 = + let* a = Bam.Std.int ~min:30 () in + let* b = Bam.Std.string ~size:(Bam.Std.int ~max:10 ()) () in + return {a; b} + +let _ = gen_c4 + +[@@@end] + +type c5 = int32 [@@deriving_inline gen] + +let _ = fun (_ : c5) -> () + +let gen_c5 = Bam.Std.int32 () + +let _ = gen_c5 + +[@@@end] + +type c6 = int64 [@@deriving_inline gen] + +let _ = fun (_ : c6) -> () + +let gen_c6 = Bam.Std.int64 () + +let _ = gen_c6 + +[@@@end] + +type c7 = Record of {a: int; b: string} [@@deriving_inline gen] + +let _ = fun (_ : c7) -> () + +let gen_c7 = + let* a = Bam.Std.int () in + let* b = Bam.Std.string ~size:(Bam.Std.int ~max:10 ()) () in + return (Record {a; b}) + +let _ = gen_c7 + +[@@@end] + +type c8 = + | Override of + { a: + (int option + [@gen + fun gen -> + Bam.Std.oneof + [ (1000, Bam.Std.return None) + ; ( 2 + , let* v = gen in + return (Some v) ) ]] ) + ; b: int option } +[@@deriving_inline gen] + +let _ = fun (_ : c8) -> () + +let gen_c8 = + let* a = + (fun gen -> + Bam.Std.oneof + [ (1000, Bam.Std.return None) + ; ( 2 + , let* v = gen in + return (Some v) ) ] ) + (Bam.Std.int ()) + in + let* b = + let gen__006_ = Bam.Std.int () in + Bam.Std.oneof + [ (1, return None) + ; ( 1 + , let* value = gen__006_ in + return (Some value) ) ] + in + return (Override {a; b}) + +let _ = gen_c8 + +[@@@end] + +type 'a missing = 'a list + +type 'a c9 = ('a missing[@gen Bam.Std.list ~size:(Bam.Std.int ~max:10 ())]) +[@@deriving_inline gen] + +let _ = fun (_ : 'a c9) -> () + +let gen_c9 gen_a = Bam.Std.list ~size:(Bam.Std.int ~max:10 ()) gen_a + +let _ = gen_c9 + +[@@@end] + +let my_int = Bam.Std.int () + +type c10 = {a: (int[@min 5]); b: (int[@max 20])} +[@@deriving_inline gen] [@@gen.int my_int] + +let _ = fun (_ : c10) -> () + +let gen_c10 = + let* a = my_int in + let* b = my_int in + return {a; b} + +let _ = gen_c10 + +[@@@end] + +let my_option gen = + let some = + let* v = gen in + return (Some v) + in + Bam.Std.oneof [(2, Bam.Std.return None); (3, some)] + +type c11 = {a: int option} [@@deriving_inline gen] [@@gen.option my_option] + +let _ = fun (_ : c11) -> () + +let gen_c11 = + let* a = my_option (Bam.Std.int ()) in + return {a} + +let _ = gen_c11 + +[@@@end] + +type c12 = + | A of int [@weight 5] [@min 5] [@max 15] + | B of string [@weight 4] + | C of int [@weight 3] +[@@deriving_inline gen] + +let _ = fun (_ : c12) -> () + +let gen_c12 = + let gen_A = + let* arg_0 = Bam.Std.int ~min:5 ~max:15 () in + return (A arg_0) + in + let gen_B = + let* arg_0 = Bam.Std.string ~size:(Bam.Std.int ~max:10 ()) () in + return (B arg_0) + in + let gen_C = + let* arg_0 = Bam.Std.int () in + return (C arg_0) + in + Bam.Std.oneof [(5, gen_A); (4, gen_B); (3, gen_C)] + +let _ = gen_c12 + +[@@@end]