unikernel/duniverse/ppxlib/test/ast_builder_value_binding/dune

@@ -0,0 +1,16 @@
+(rule
+ (package ppxlib)
+ (alias runtest)
+ ; #install_printer is not working on older compilers for some reason
+ ; This is fine as this does not need to be tested on older compilers anyway
+ (enabled_if
+  (>= %{ocaml_version} 5.1))
+ (deps
+  (:test test.ml)
+  (package ppxlib))
+ (action
+  (chdir
+   %{project_root}
+   (progn
+    (run expect-test %{test})
+    (diff? %{test} %{test}.corrected)))))

unikernel/duniverse/ppxlib/test/ast_builder_value_binding/test.ml

@@ -0,0 +1,198 @@
+open Ppxlib
+
+(* This file contains tests to ensure that [Ast_builder.value_binding] properly
+   translates the given [pattern] and [expression] pair into the correct
+   [pattern], [expression] and [value_constraint] triple. *)
+
+
+(* ------- Test Setup -------- *)
+
+#install_printer Pp_ast.Default.structure_item;;
+#install_printer Pp_ast.Default.expression;;
+#install_printer Pp_ast.Default.pattern;;
+
+let loc = Location.none
+[%%ignore]
+
+(* --------- Simple case, no translation --------- *)
+
+let pat = [%pat? f]
+let expr = [%expr fun x -> x + 1]
+[%%ignore]
+
+let vb =
+  let open Ast_builder.Default in
+  pstr_value ~loc Nonrecursive [value_binding ~pat ~expr ~loc]
+
+[%%expect{|
+val vb : structure_item =
+  Pstr_value
+    ( Nonrecursive
+    , [ { pvb_pat = Ppat_var "f"
+        ; pvb_expr =
+            Pexp_function
+              ( [ { pparam_loc = __loc
+                  ; pparam_desc = Pparam_val ( Nolabel, None, Ppat_var "x")
+                  }
+                ]
+              , None
+              , Pfunction_body
+                  (Pexp_apply
+                     ( Pexp_ident (Lident "+")
+                     , [ ( Nolabel, Pexp_ident (Lident "x"))
+                       ; ( Nolabel
+                         , Pexp_constant (Pconst_integer ( "1", None))
+                         )
+                       ]
+                     ))
+              )
+        ; pvb_constraint = None
+        ; pvb_attributes = __attrs
+        ; pvb_loc = __loc
+        }
+      ]
+    )
+|}]
+
+(* As expected here, the [pvb_constraint] field is none, the pattern and
+   expression are used as is. *)
+
+(* --------- No var Ppat_constraint to pvb_constraint --------- *)
+
+let pat = [%pat? (x : int)]
+let expr = [%expr 12]
+[%%ignore]
+
+let vb =
+  let open Ast_builder.Default in
+  pstr_value ~loc Nonrecursive [value_binding ~pat ~expr ~loc]
+
+[%%expect{|
+val vb : structure_item =
+  Pstr_value
+    ( Nonrecursive
+    , [ { pvb_pat = Ppat_var "x"
+        ; pvb_expr = Pexp_constant (Pconst_integer ( "12", None))
+        ; pvb_constraint =
+            Some
+              (Pvc_constraint
+                 { locally_abstract_univars = []
+                 ; typ = Ptyp_constr ( Lident "int", [])
+                 })
+        ; pvb_attributes = __attrs
+        ; pvb_loc = __loc
+        }
+      ]
+    )
+|}]
+
+(* --------- poly Ppat_constraint to pvb_constraint --------- *)
+
+let pat =
+  Ast_builder.Default.ppat_constraint ~loc
+    [%pat? f]
+    (Ast_builder.Default.ptyp_poly ~loc
+       [ Loc.make ~loc "a" ]
+       [%type: 'a -> unit])
+
+let expr = [%expr fun x -> unit]
+
+[%%ignore]
+
+let vb =
+  let open Ast_builder.Default in
+  pstr_value ~loc Nonrecursive [value_binding ~pat ~expr ~loc]
+
+[%%expect{|
+val vb : structure_item =
+  Pstr_value
+    ( Nonrecursive
+    , [ { pvb_pat = Ppat_var "f"
+        ; pvb_expr =
+            Pexp_function
+              ( [ { pparam_loc = __loc
+                  ; pparam_desc = Pparam_val ( Nolabel, None, Ppat_var "x")
+                  }
+                ]
+              , None
+              , Pfunction_body (Pexp_ident (Lident "unit"))
+              )
+        ; pvb_constraint =
+            Some
+              (Pvc_constraint
+                 { locally_abstract_univars = []
+                 ; typ =
+                     Ptyp_poly
+                       ( [ "a"]
+                       , Ptyp_arrow
+                           ( Nolabel
+                           , Ptyp_var "a"
+                           , Ptyp_constr ( Lident "unit", [])
+                           )
+                       )
+                 })
+        ; pvb_attributes = __attrs
+        ; pvb_loc = __loc
+        }
+      ]
+    )
+|}]
+
+(* --------- desugared locally abstract univars to pvb_constraint --------- *)
+
+let pat =
+  Ast_builder.Default.ppat_constraint ~loc
+    [%pat? f]
+    (Ast_builder.Default.ptyp_poly ~loc
+       [ Loc.make ~loc "a" ]
+       [%type: 'a -> unit])
+
+let expr = [%expr fun (type a) -> (fun _ -> unit : a -> unit)]
+
+[%%ignore]
+
+let vb =
+  let open Ast_builder.Default in
+  pstr_value ~loc Nonrecursive [value_binding ~pat ~expr ~loc]
+
+[%%expect{|
+val vb : structure_item =
+  Pstr_value
+    ( Nonrecursive
+    , [ { pvb_pat = Ppat_var "f"
+        ; pvb_expr =
+            Pexp_function
+              ( [ { pparam_loc = __loc
+                  ; pparam_desc = Pparam_val ( Nolabel, None, Ppat_any)
+                  }
+                ]
+              , None
+              , Pfunction_body (Pexp_ident (Lident "unit"))
+              )
+        ; pvb_constraint =
+            Some
+              (Pvc_constraint
+                 { locally_abstract_univars = [ "a"]
+                 ; typ =
+                     Ptyp_arrow
+                       ( Nolabel
+                       , Ptyp_constr ( Lident "a", [])
+                       , Ptyp_constr ( Lident "unit", [])
+                       )
+                 })
+        ; pvb_attributes = __attrs
+        ; pvb_loc = __loc
+        }
+      ]
+    )
+|}]
+
+(* As expected here, the matching constraint from the pattern and expression or
+   recombined into a single value constraint with locally abstract univars set
+   correctly. *)
+
+(* --------- coercion to pvb_constraint --------- *)
+
+(*TODO*)
+[%%expect{|
+|}]