PPX: Allow expressions in attributes

lib_ppx/attributes.ml

@@ -3,6 +3,8 @@ include Attribute
 open Runtime
 open Ty
 
+let loc = !Ast_helper.default_loc
+
 module State_monad = struct
   type ('node, 'state) t = 'node -> 'state -> 'node * 'state
 
@@ -44,19 +46,19 @@ module Generic : sig
 end = struct
   let min context =
     Attribute.declare "gen.min" context
-      Ast_pattern.(single_expr_payload (eint __))
+      Ast_pattern.(single_expr_payload __)
       (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 __))
+      Ast_pattern.(single_expr_payload __)
       (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 __))
+      Ast_pattern.(single_expr_payload __)
       (fun min runtime ->
         { runtime with
           limits=
@@ -66,7 +68,7 @@ end = struct
 
   let int_max context =
     Attribute.declare "gen.int.max" context
-      Ast_pattern.(single_expr_payload (eint __))
+      Ast_pattern.(single_expr_payload __)
       (fun max runtime ->
         { runtime with
           limits=
@@ -76,7 +78,7 @@ end = struct
 
   let int32_min context =
     Attribute.declare "gen.int32.min" context
-      Ast_pattern.(single_expr_payload (eint32 __))
+      Ast_pattern.(single_expr_payload __)
       (fun min runtime ->
         { runtime with
           limits=
@@ -86,7 +88,7 @@ end = struct
 
   let int32_max context =
     Attribute.declare "gen.int32.max" context
-      Ast_pattern.(single_expr_payload (eint32 __))
+      Ast_pattern.(single_expr_payload __)
       (fun max runtime ->
         { runtime with
           limits=
@@ -96,7 +98,7 @@ end = struct
 
   let int64_min context =
     Attribute.declare "gen.int64.min" context
-      Ast_pattern.(single_expr_payload (eint64 __))
+      Ast_pattern.(single_expr_payload __)
       (fun min runtime ->
         { runtime with
           limits=
@@ -106,7 +108,7 @@ end = struct
 
   let int64_max context =
     Attribute.declare "gen.int64.max" context
-      Ast_pattern.(single_expr_payload (eint64 __))
+      Ast_pattern.(single_expr_payload __)
       (fun max runtime ->
         { runtime with
           limits=
@@ -116,37 +118,41 @@ end = struct
 
   let size_min context =
     Attribute.declare "gen.size.min" context
-      Ast_pattern.(single_expr_payload (eint __))
+      Ast_pattern.(single_expr_payload __)
       (fun size_min runtime ->
         { runtime with
-          limits= {runtime.limits with size_min= Some (Int.max 0 size_min)} } )
+          limits=
+            {runtime.limits with size_min= Some [%expr Int.max 0 [%e size_min]]}
+        } )
 
   let size_max context =
     Attribute.declare "gen.size.max" context
-      Ast_pattern.(single_expr_payload (eint __))
+      Ast_pattern.(single_expr_payload __)
       (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 __))
+      Ast_pattern.(single_expr_payload __)
       (fun size_min runtime ->
         { runtime with
           limits=
             { runtime.limits with
               sized_min=
-                Sized_map.add (E String) (Int.max 0 size_min)
+                Sized_map.add (E String)
+                  [%expr Int.max 0 [%e size_min]]
                   runtime.limits.sized_min } } )
 
   let string_size_max context =
     Attribute.declare "gen.string.size.max" context
-      Ast_pattern.(single_expr_payload (eint __))
+      Ast_pattern.(single_expr_payload __)
       (fun size_max runtime ->
         { runtime with
           limits=
             { runtime.limits with
               sized_max=
-                Sized_map.add (E String) (Int.max 0 size_max)
+                Sized_map.add (E String)
+                  [%expr Int.max 0 [%e size_max]]
                   runtime.limits.sized_max } } )
 
   let overrides =

lib_ppx/limits.ml

@@ -1,20 +1,22 @@
 open Ty
 
+let loc = !Ast_helper.default_loc
+
 type t =
-  { min: int option
-  ; max: int option
-  ; size_min: int option
-  ; size_max: int option
+  { min: Ppxlib.expression option
+  ; max: Ppxlib.expression option
+  ; size_min: Ppxlib.expression option
+  ; size_max: Ppxlib.expression option
   ; ranged_min: Ranged_dmap.t
   ; ranged_max: Ranged_dmap.t
-  ; sized_min: int Sized_map.t
-  ; sized_max: int Sized_map.t }
+  ; sized_min: Ppxlib.expression Sized_map.t
+  ; sized_max: Ppxlib.expression Sized_map.t }
 
 let default =
   { min= None
   ; max= None
   ; size_min= None
-  ; size_max= Some 10
+  ; size_max= Some [%expr 10]
   ; ranged_min= Ranged_dmap.empty
   ; ranged_max= Ranged_dmap.empty
   ; sized_min= Sized_map.empty
@@ -37,28 +39,28 @@ let int_max limits =
 let int32_min limits =
   match Ranged_dmap.find_opt Int32 limits.ranged_min with
   | None ->
-      limits.min |> Option.map Int32.of_int
+      limits.min
   | 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
+      limits.max
   | 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
+      limits.min
   | 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
+      limits.max
   | Some i ->
       Some i
 

lib_ppx/runtime.ml

@@ -13,8 +13,6 @@ module Default = struct
         [%expr Bam.Std.bool ~shrinker:[%e shrinker] ()]
 
   let int ~shrinker ~min ~max () =
-    let min = Option.map (Ast_builder.Default.eint ~loc) min in
-    let max = Option.map (Ast_builder.Default.eint ~loc) max in
     let gen =
       match shrinker with
       | None ->
@@ -33,8 +31,6 @@ module Default = struct
         [%expr [%e gen] ~min:[%e min] ~max:[%e max] ()]
 
   let int32 ~shrinker ~min ~max () =
-    let min = Option.map (Ast_builder.Default.eint32 ~loc) min in
-    let max = Option.map (Ast_builder.Default.eint32 ~loc) max in
     let gen =
       match shrinker with
       | None ->
@@ -53,8 +49,6 @@ module Default = struct
         [%expr [%e gen] ~min:[%e min] ~max:[%e max] ()]
 
   let int64 ~shrinker ~min ~max () =
-    let min = Option.map (Ast_builder.Default.eint64 ~loc) min in
-    let max = Option.map (Ast_builder.Default.eint64 ~loc) max in
     let gen =
       match shrinker with
       | None ->

lib_ppx/ty.ml

@@ -1,6 +1,9 @@
 open Ppxlib
 
-type _ ranged = Int : int ranged | Int32 : int32 ranged | Int64 : int64 ranged
+type _ ranged =
+  | Int : expression ranged
+  | Int32 : expression ranged
+  | Int64 : expression ranged
 
 let ranged_compare (type a1 a2) : a1 ranged -> a2 ranged -> (a1, a2) Dmap.cmp =
  fun left right ->

lib_ppx/ty.mli

@@ -1,6 +1,9 @@
 open Ppxlib
 
-type _ ranged = Int : int ranged | Int32 : int32 ranged | Int64 : int64 ranged
+type _ ranged =
+  | Int : expression ranged
+  | Int32 : expression ranged
+  | Int64 : expression ranged
 
 val ranged_compare : 'a ranged -> 'b ranged -> ('a, 'b) Dmap.cmp
 

test/ppx.ml

@@ -503,15 +503,18 @@ module Advanced = struct
 
   [@@@end]
 
-  type t6 = {a: (int[@max 20]); b: string} [@@deriving_inline gen] [@@min 5]
+  type t6 = {a: (int[@max 30 + 20]); b: string}
+  [@@deriving_inline gen] [@@min 5]
 
   let _ = fun (_ : t6) -> ()
 
-  let gen_t6 =
-    let open Bam.Std.Syntax in
-    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_t6 =
+  let open Bam.Std.Syntax in
+    let* a = Bam.Std.int ~min:5 ~max:(30 + 20) ()
+     in
+    let* b = Bam.Std.string ~size:(Bam.Std.int ~max:10 ()) ()
+     in return { a; b }
 
   let _ = gen_t6