unikernel/duniverse/ppxlib/test/pprintast/oldschool-constraints/dune

@@ -0,0 +1,9 @@
+(executables
+ (names pprint_pvb_constraint pprint_ppat_constraint)
+ (libraries ppxlib astlib)
+ (preprocess
+  (pps ppxlib.metaquot)))
+
+(cram
+ (package ppxlib)
+ (deps pprint_pvb_constraint.exe pprint_ppat_constraint.exe))

unikernel/duniverse/ppxlib/test/pprintast/oldschool-constraints/pprint_ppat_constraint.ml

@@ -0,0 +1,34 @@
+open Ppxlib
+
+let loc = Location.none
+
+let ast =
+  let vbs =
+    let pat =
+      Ast_builder.Default.ppat_constraint ~loc
+        [%pat? f]
+        (Ast_builder.Default.ptyp_poly ~loc
+           [ Loc.make ~loc "a" ]
+           [%type: 'a -> unit])
+    in
+    let expr = [%expr fun _ -> ()] in
+    (* It is important that this is either built using [Latest.value_binding]
+       or assembled manually as [Ast_builder.Defaut.value_binding] will
+       generate a pvb_constraint, entirely defeatin the test's purpose. *)
+    [ Ast_builder.Default.Latest.value_binding ~loc ~pat ~expr () ]
+  in
+  Ast_builder.Default.pstr_value ~loc Nonrecursive vbs
+
+let print_source () = Format.printf "%a\n" Pprintast.structure_item ast
+let print_ast () = Format.printf "%a\n" Pp_ast.Default.structure_item ast
+
+let () =
+  match Sys.argv with
+  | [| _exec |] -> print_source ()
+  | [| _exec; _flag |] ->
+      print_ast ();
+      Format.printf "------- PRINTED AS -------\n";
+      print_source ()
+  | _ ->
+      Printf.eprintf "Invalid usage!";
+      exit 1

unikernel/duniverse/ppxlib/test/pprintast/oldschool-constraints/pprint_pvb_constraint.ml

@@ -0,0 +1,35 @@
+open Ppxlib
+
+let loc = Location.none
+
+let ast =
+  let vbs =
+    let pat = [%pat? f] in
+    let expr = [%expr fun _ -> ()] in
+    let constraint_ =
+      Pvc_constraint
+        {
+          locally_abstract_univars = [];
+          typ =
+            Ast_builder.Default.ptyp_poly ~loc
+              [ Loc.make ~loc "a" ]
+              [%type: 'a -> unit];
+        }
+    in
+    [ Ast_builder.Default.Latest.value_binding ~loc ~pat ~expr ~constraint_ () ]
+  in
+  Ast_builder.Default.pstr_value ~loc Nonrecursive vbs
+
+let print_source () = Format.printf "%a\n" Pprintast.structure_item ast
+let print_ast () = Format.printf "%a\n" Pp_ast.Default.structure_item ast
+
+let () =
+  match Sys.argv with
+  | [| _exec |] -> print_source ()
+  | [| _exec; _flag |] ->
+      print_ast ();
+      Format.printf "------- PRINTED AS -------\n";
+      print_source ()
+  | _ ->
+      Printf.eprintf "Invalid usage!";
+      exit 1

unikernel/duniverse/ppxlib/test/pprintast/oldschool-constraints/run.t

@@ -0,0 +1,84 @@
+We have two executables that prints the same bit of code:
+let f : 'a . 'a -> unit = ()
+but represented with different ASTs: pprint_pvb_constraint encodes the type
+constraint in the pvb_constraint field of the value_binding while
+pprint_ppat_constraint encodes it in the pvb_pat field, i.e. the legacy way.
+
+
+  $ ./pprint_pvb_constraint.exe --with-ast
+  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_construct ( Lident "()", None))
+              )
+        ; 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
+        }
+      ]
+    )
+  ------- PRINTED AS -------
+  let f : 'a . 'a -> unit = fun _ -> ()
+
+  $ ./pprint_ppat_constraint.exe --with-ast
+  Pstr_value
+    ( Nonrecursive
+    , [ { pvb_pat =
+            Ppat_constraint
+              ( Ppat_var "f"
+              , Ptyp_poly
+                  ( [ "a"]
+                  , Ptyp_arrow
+                      ( Nolabel
+                      , Ptyp_var "a"
+                      , Ptyp_constr ( Lident "unit", [])
+                      )
+                  )
+              )
+        ; pvb_expr =
+            Pexp_function
+              ( [ { pparam_loc = __loc
+                  ; pparam_desc = Pparam_val ( Nolabel, None, Ppat_any)
+                  }
+                ]
+              , None
+              , Pfunction_body (Pexp_construct ( Lident "()", None))
+              )
+        ; pvb_constraint = None
+        ; pvb_attributes = __attrs
+        ; pvb_loc = __loc
+        }
+      ]
+    )
+  ------- PRINTED AS -------
+  let f : 'a . 'a -> unit = fun _ -> ()
+
+The legacy gets printed the same way as the pvb_constraint version to allow both
+representation to coexist. The compiler's pprintast doesn't support it and prints
+an incorrect syntax that does not parse. The compiler itself still seems to accept
+such ASTs though, hence why we modified our pprintast to allow those.
+
+The output should be accepted by the parser:
+
+  $ ./pprint_ppat_constraint.exe > test.ml
+  $ ocamlc test.ml