(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))

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]

[ 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

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

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