Backport polymorphic parameters (#2772)

* parser-std: Backport polymorphic paramters

From ocaml/ocaml#13806

* parser-ext: Backport polymorphic parameters

* Fix Ast rules for Ptyp_poly

It is treated with the same precedence as Ptyp_arrow.

Author: Julow

CHANGES.md

@@ -8,6 +8,8 @@ profile. This started with version 0.26.0.
 
 ### Highlight
 
+- Support OCaml 5.5 syntax (#2772, @Julow)
+
 - \* Update Odoc's parser to 3.0 (#2757, @Julow)
   The indentation of code-blocks containing OCaml code is reduced by 2 to avoid
   changing the generated documentation. The indentation within code-blocks is

lib/Ast.ml

@@ -1605,27 +1605,35 @@ end = struct
       | _ -> false
     in
     let constructor_cxt_prec_of_inner = function
-      | {ptyp_desc= Ptyp_arrow _; _} -> Some (Apply, Non)
+      | {ptyp_desc= Ptyp_arrow _ | Ptyp_poly _; _} -> Some (Apply, Non)
       | {ptyp_desc= Ptyp_tuple _; _} -> Some (InfixOp3, Non)
       | _ -> None
     in
     match ctx with
     | { ctx= Td {ptype_kind= Ptype_variant v; _}
-      ; ast= Typ ({ptyp_desc= Ptyp_arrow _ | Ptyp_tuple _; _} as typ) }
+      ; ast=
+          Typ
+            ({ptyp_desc= Ptyp_arrow _ | Ptyp_poly _ | Ptyp_tuple _; _} as typ)
+      }
       when List.exists v ~f:(is_tuple_lvl1_in_constructor typ) ->
         constructor_cxt_prec_of_inner typ
     | { ctx=
           ( Str {pstr_desc= Pstr_typext {ptyext_constructors= l; _}; _}
           | Sig {psig_desc= Psig_typext {ptyext_constructors= l; _}; _} )
-      ; ast= Typ ({ptyp_desc= Ptyp_arrow _ | Ptyp_tuple _; _} as typ)
+      ; ast=
+          Typ
+            ({ptyp_desc= Ptyp_arrow _ | Ptyp_poly _ | Ptyp_tuple _; _} as typ)
       ; _ }
       when List.exists l ~f:(is_tuple_lvl1_in_ext_constructor typ) ->
         constructor_cxt_prec_of_inner typ
     | { ctx=
           ( Str {pstr_desc= Pstr_exception {ptyexn_constructor= constr; _}; _}
           | Sig {psig_desc= Psig_exception {ptyexn_constructor= constr; _}; _}
           | Exp {pexp_desc= Pexp_letexception (constr, _, _); _} )
-      ; ast= Typ ({ptyp_desc= Ptyp_tuple _ | Ptyp_arrow _; _} as typ) }
+      ; ast=
+          Typ
+            ({ptyp_desc= Ptyp_tuple _ | Ptyp_arrow _ | Ptyp_poly _; _} as typ)
+      }
       when is_tuple_lvl1_in_ext_constructor typ constr ->
         constructor_cxt_prec_of_inner typ
     | {ctx= Str _; ast= Typ _; _} -> None
@@ -1637,13 +1645,13 @@ end = struct
             else Right
           in
           Some (MinusGreater, assoc)
+      | Ptyp_poly _ -> Some (MinusGreater, Right)
       | Ptyp_tuple _ -> Some (InfixOp3, Non)
       | Ptyp_alias _ -> Some (As, Non)
       | Ptyp_constr (_, _ :: _ :: _) -> Some (Comma, Non)
       | Ptyp_constr _ -> Some (Apply, Non)
       | Ptyp_any | Ptyp_var _ | Ptyp_object _ | Ptyp_class _
-       |Ptyp_variant _ | Ptyp_poly _ | Ptyp_package _ | Ptyp_extension _
-       |Ptyp_open _ ->
+       |Ptyp_variant _ | Ptyp_package _ | Ptyp_extension _ | Ptyp_open _ ->
           None )
     | {ctx= Cty {pcty_desc; _}; ast= Typ typ; _} -> (
       match pcty_desc with
@@ -1772,12 +1780,11 @@ end = struct
     | Typ {ptyp_desc; _} -> (
       match ptyp_desc with
       | Ptyp_package _ -> Some Low
-      | Ptyp_arrow _ -> Some MinusGreater
+      | Ptyp_arrow _ | Ptyp_poly _ -> Some MinusGreater
       | Ptyp_tuple _ -> Some InfixOp3
       | Ptyp_alias _ -> Some As
       | Ptyp_any | Ptyp_var _ | Ptyp_constr _ | Ptyp_object _
-       |Ptyp_class _ | Ptyp_variant _ | Ptyp_poly _ | Ptyp_extension _
-       |Ptyp_open _ ->
+       |Ptyp_class _ | Ptyp_variant _ | Ptyp_extension _ | Ptyp_open _ ->
           None )
     | Td _ -> None
     | Cty {pcty_desc; _} -> (
@@ -1872,7 +1879,7 @@ end = struct
     match xtyp with
     | {ast= {ptyp_desc= Ptyp_package _; _}; _} -> true
     | {ast= {ptyp_desc= Ptyp_alias _; _}; ctx= Typ _} -> true
-    | { ast= {ptyp_desc= Ptyp_arrow _ | Ptyp_tuple _; _}
+    | { ast= {ptyp_desc= Ptyp_arrow _ | Ptyp_poly _ | Ptyp_tuple _; _}
       ; ctx= Typ {ptyp_desc= Ptyp_class _; _} } ->
         true
     | { ast= {ptyp_desc= Ptyp_alias _; _}
@@ -1887,13 +1894,16 @@ end = struct
                | Pcstr_tuple l -> List.exists l ~f:(phys_equal typ)
                | _ -> false ) ->
         true
-    | { ast= {ptyp_desc= Ptyp_alias _ | Ptyp_arrow _ | Ptyp_tuple _; _}
+    | { ast=
+          { ptyp_desc=
+              Ptyp_alias _ | Ptyp_arrow _ | Ptyp_poly _ | Ptyp_tuple _
+          ; _ }
       ; ctx=
           ( Str {pstr_desc= Pstr_exception _; _}
           | Sig {psig_desc= Psig_exception _; _} ) } ->
         true
     | { ast= {ptyp_desc= Ptyp_tuple ({lte_label= Some _; _} :: _); _}
-      ; ctx= Typ {ptyp_desc= Ptyp_arrow _; _} } ->
+      ; ctx= Typ {ptyp_desc= Ptyp_arrow _ | Ptyp_poly _; _} } ->
         true
     | _ -> (
       match ambig_prec (sub_ast ~ctx (Typ typ)) with
@@ -1987,7 +1997,6 @@ end = struct
     | Fpe {pparam_desc= Pparam_val (_, _, _); _}, Ppat_cons _ -> true
     | Fpc {pparam_desc= _; _}, Ppat_cons _ -> true
     | Pat {ppat_desc= Ppat_construct _; _}, Ppat_cons _ -> true
-    | _, Ppat_constraint (_, {ptyp_desc= Ptyp_poly _; _}) -> false
     | ( Bo {pbop_typ= None; _}
       , ( Ppat_construct (_, Some _)
         | Ppat_cons _

test/passing/gen/dune.inc

@@ -4591,6 +4591,24 @@
  (package ocamlformat)
  (action (diff parens_tuple_patterns.ml.err parens_tuple_patterns.ml.stderr)))
 
+(rule
+ (deps .ocamlformat)
+ (package ocamlformat)
+ (action
+  (with-stdout-to poly_params.ml.stdout
+   (with-stderr-to poly_params.ml.stderr
+     (run %{bin:ocamlformat} --name poly_params.ml --margin-check %{dep:../tests/poly_params.ml})))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff poly_params.ml.ref poly_params.ml.stdout)))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff poly_params.ml.err poly_params.ml.stderr)))
+
 (rule
  (deps .ocamlformat)
  (package ocamlformat)

test/passing/refs.ahrefs/poly_params.ml.ref

@@ -0,0 +1,215 @@
+(* This test is extracted from the compiler's testsuite. *)
+
+let poly1 (id : 'a. 'a -> 'a) = id 3, id "three"
+
+let _ = poly1 (fun x -> x)
+
+let _ = poly1 (fun x -> x + 1)
+
+let id x = x
+let _ = poly1 id
+
+let _ = poly1 (id (fun x -> x))
+
+let _ =
+  poly1
+    (let r = ref None in
+     fun x ->
+       r := Some x;
+       x)
+
+let escape f =
+  poly1 (fun x ->
+    f x;
+    x)
+
+let poly2 : ('a. 'a -> 'a) -> int * string = fun id -> id 3, id "three"
+
+let _ = poly2 (fun x -> x)
+
+let _ = poly2 (fun x -> x + 1)
+
+let poly3 : 'b. ('a. 'a -> 'a) -> 'b -> 'b * 'b option =
+ fun id x -> id x, id (Some x)
+
+let _ = poly3 (fun x -> x) 8
+
+let _ = poly3 (fun x -> x + 1) 8
+
+let rec poly4 p (id : 'a. 'a -> 'a) =
+  if p then poly4 false id else id 4, id "four"
+
+let _ = poly4 true (fun x -> x)
+
+let _ = poly4 true (fun x -> x + 1)
+
+let rec poly5 : bool -> ('a. 'a -> 'a) -> int * string =
+ fun p id -> if p then poly5 false id else id 5, id "five"
+
+let _ = poly5 true (fun x -> x)
+
+let _ = poly5 true (fun x -> x + 1)
+
+let rec poly6 : 'b. bool -> ('a. 'a -> 'a) -> 'b -> 'b * 'b option =
+ fun p id x -> if p then poly6 false id x else id x, id (Some x)
+
+let _ = poly6 true (fun x -> x) 8
+
+let _ = poly6 true (fun x -> x + 1) 8
+
+let needs_magic (magic : 'a 'b. 'a -> 'b) = (magic 5 : string)
+let _ = needs_magic (fun x -> x)
+
+let with_id (f : ('a. 'a -> 'a) -> 'b) = f (fun x -> x)
+
+let _ = with_id (fun id -> id 4, id "four")
+
+let non_principal1 p f = if p then with_id f else f (fun x -> x)
+
+let non_principal2 p f = if p then f (fun x -> x) else with_id f
+
+let principal1 p (f : ('a. 'a -> 'a) -> 'b) =
+  if p then f (fun x -> x) else with_id f
+
+let principal2 : bool -> (('a. 'a -> 'a) -> 'b) -> 'b =
+ fun p f -> if p then f (fun x -> x) else with_id f
+
+type poly = ('a. 'a -> 'a) -> int * string
+
+let principal3 : poly option list = [ None; Some (fun x -> x 5, x "hello") ]
+
+let non_principal3 =
+  [
+    (Some (fun x -> x 5, x "hello") : poly option);
+    Some (fun y -> y 6, y "goodbye");
+  ]
+
+let non_principal4 =
+  [
+    Some (fun y -> y 6, y "goodbye");
+    (Some (fun x -> x 5, x "hello") : poly option);
+  ]
+
+(* Functions with polymorphic parameters are separate from other functions *)
+type 'a arg = 'b constraint 'a = 'b -> 'c
+type really_poly = (('a. 'a -> 'a) -> string) arg
+
+(* Polymorphic parameters are (mostly) treated as invariant *)
+type p1 = ('a. 'a -> 'a) -> int
+type p2 = ('a 'b. 'a -> 'b) -> int
+
+let foo (f : p1) : p2 = f
+
+let foo f = (f : p1 :> p2)
+
+module Foo (X : sig
+  val f : p1
+end) : sig
+  val f : p2
+end =
+  X
+
+let foo (f : p1) : p2 = fun id -> f id
+
+(* Following the existing behaviour for polymorphic methods, you can
+   subtype from a polymorphic parameter to a monomorphic
+   parameter. Elsewhere it still behaves as invariant. *)
+type p1 = (bool -> bool) -> int
+type p2 = ('a. 'a -> 'a) -> int
+
+let foo (x : p1) : p2 = x
+
+let foo x = (x : p1 :> p2)
+
+module Foo (X : sig
+  val f : p1
+end) : sig
+  val f : p2
+end =
+  X
+
+let foo (f : p1) : p2 = fun id -> f id
+
+class c (f : 'a. 'a -> 'a) =
+  object
+    method m = f 0
+    method n = f "a"
+  end
+
+class c' (f : 'a. int -> int) =
+  object
+    method m = f 0
+  end
+
+let poly1' ~(id : 'a. 'a -> 'a) = id 3, id "three"
+
+let poly2' ?(id : 'a. 'a -> 'a) = id 3, id "three"
+
+let poly3' ?(id : 'a. int -> int) = id 3
+
+(* This test illustrate a new occurrence of the bug discussed in
+   https://github.com/ocaml/ocaml/pull/13984*)
+
+module type T = sig
+  type 'a t = 'a list
+end
+
+let rec f (x : (module T)) =
+  let (module LocalModule) = x in
+  (assert false : ('a. 'a LocalModule.t) -> unit)
+
+(* The following test requires full translation in the [approx_type] function if
+   the annotation is partial. *)
+let rec f () = g () Fun.id
+
+and g () : ('a. 'a -> 'a) -> unit = fun _ -> ()
+
+let rec f () = g () Fun.id
+
+and g : unit -> ('a. 'a -> 'a) -> unit = fun () _ -> ()
+
+(* Attempts at breaking type_pattern_approx *)
+let rec f ([] : 'a. 'a list) = ()
+
+let rec f () : ('a. 'a list) -> unit = fun [] -> ()
+
+(* New expert trick: use 'a. to trigger "exact approximation" *)
+let rec f () = g (module Map.Make (Int))
+
+and g (m : (module Map.S)) = ()
+
+let rec f () = g (module Map.Make (Int))
+
+and g (m : 'a. (module Map.S)) = ()
+
+(* Check that we are getting the right behaviour for polymorphic variants
+   in polymorphic parameters. *)
+
+let poly_poly_var : [< `A | `B ] -> unit = function
+  | `A -> ()
+  | `B -> ()
+
+let accept_poly_poly_var (g : 'a. ([< `A | `B ] as 'a) -> unit) = g `A
+
+let () = accept_poly_poly_var poly_poly_var
+
+let f (`B | _) = ()
+let h (f : 'a. ([> `A ] as 'a) -> unit) = f `B
+let error = h f
+
+let ( let* ) x (id : 'a. 'a -> 'a) = id x, id 1
+
+let ( let* ) (x : 'a. 'a option) (id : 'a. 'a -> 'a) = id x, id 1
+
+let y =
+  let* x = 3. in
+  x
+
+let f ((g, x) : 'a. ('a -> int) * 'a) = g 3, g "three"
+
+let f (x : [< `A of ('a. 'a option) -> unit ]) =
+  match x with
+  | `A f -> f None
+
+let f : type a. unit -> (a, ('b. 'b -> 'b) -> int) Type.eq -> a =
+ fun () Equal f -> f 0