simplify poly vs. modes

Author: riaqn

otherlibs/stdlib_alpha/capsule.ml

@@ -584,8 +584,8 @@ module Mutex = struct
   exception Poisoned
 
   let[@inline] with_lock :
-    (type k.
-    k t
+    type k.
+    (k t
     -> (k Password.t @ local -> 'a) @ local
     -> 'a)
     @ portable
@@ -646,8 +646,8 @@ module Rwlock = struct
   exception Poisoned
 
   let[@inline] with_write_lock :
-    (type k.
-    k t
+    type k.
+    (k t
     -> (k Password.t @ local -> 'a) @ local
     -> 'a)
     @ portable
@@ -678,8 +678,8 @@ module Rwlock = struct
           raise exn
 
   let[@inline] with_read_lock :
-    (type k.
-    k t
+    type k.
+    (k t
     -> (k Password.Shared.t @ local unyielding -> 'a) @ local
     -> 'a)
     @ portable

parsing/parser.mly

@@ -3175,8 +3175,8 @@ let_binding_body_no_punning:
         (v, $5, Some (Pvc_constraint { locally_abstract_univars = []; typ }),
          modes)
       }
-  | let_ident_with_modes COLON        TYPE ntys = newtypes DOT cty = core_type        modes1 = empty_list EQUAL e = seq_expr
-  | let_ident_with_modes COLON LPAREN TYPE ntys = newtypes DOT cty = core_type RPAREN modes1=at_mode_expr EQUAL e = seq_expr
+  | let_ident_with_modes COLON TYPE ntys = newtypes DOT cty = core_type  modes1 = empty_list EQUAL e = seq_expr
+  | let_ident_with_modes COLON TYPE ntys = newtypes DOT cty = tuple_type modes1=at_mode_expr EQUAL e = seq_expr
       (* The code upstream looks like:
          {[
            let constraint' =
@@ -4301,9 +4301,13 @@ possibly_poly(X):
     { $1 }
 ;
 
+%inline strictly_poly_tuple_type:
+  strictly_poly(tuple_type)
+    { $1 }
+
 %inline poly_tuple_type:
   | tuple_type { $1 }
-  | LPAREN strictly_poly_type RPAREN { $2 }
+  | strictly_poly_tuple_type { $1 }
 ;
 
 %inline poly_type_with_modes:
@@ -4317,7 +4321,7 @@ possibly_poly(X):
 
 %inline strictly_poly_type_with_optional_modes:
   | strictly_poly_type { $1, [] }
-  | LPAREN strictly_poly_type RPAREN at_mode_expr { $2, $4 }
+  | strictly_poly_tuple_type at_mode_expr { $1, $2 }
 ;
 
 %inline poly_type_no_attr:

parsing/pprintast.ml

@@ -611,6 +611,22 @@ and core_type1 ctxt f x =
     | (Ptyp_arrow _ | Ptyp_alias _ | Ptyp_poly _) ->
        paren true (core_type ctxt) f x
 
+and core_type2 ctxt f x =
+  if x.ptyp_attributes <> [] then core_type ctxt f x
+  else
+  match x.ptyp_desc with
+  | Ptyp_poly (sl, ct) ->
+    pp f "@[<2>%a%a@]"
+           (fun f l -> match l with
+              | [] -> ()
+              | _ ->
+                  pp f "%a@;.@;"
+                    (list
+                      (tyvar_loc_jkind tyvar) ~sep:"@;")
+                      l)
+      sl (core_type1 ctxt) ct
+  | _ -> core_type1 ctxt f x
+
 and tyvar_option f = function
   | None -> pp f "_"
   | Some name -> tyvar f name
@@ -637,7 +653,7 @@ and return_type ctxt f (x, m) =
 and core_type_with_optional_modes  ctxt f (ty, modes) =
   match modes with
   | [] -> core_type ctxt f ty
-  | _ :: _ -> pp f "%a%a" (core_type1 ctxt) ty optional_at_modes modes
+  | _ :: _ -> pp f "%a%a" (core_type2 ctxt) ty optional_at_modes modes
 
 (********************pattern********************)
 (* be cautious when use [pattern], [pattern1] is preferred *)
@@ -1699,15 +1715,16 @@ and pp_print_params_then_equals ctxt f x =
         ~delimiter:"="
   | _ -> pp_print_pexp_newtype ctxt "=" f x
 
-and poly_type ctxt f (vars, typ) =
+and poly_type ctxt core_type f (vars, typ) =
   pp f "type@;%a.@;%a"
     (list ~sep:"@;" (tyvar_loc_jkind pp_print_string)) vars
     (core_type ctxt) typ
 
 and poly_type_with_optional_modes ctxt f (vars, typ, modes) =
   match modes with
-  | [] -> poly_type ctxt f (vars, typ)
-  | _ :: _ -> pp f "(%a)%a" (poly_type ctxt) (vars, typ) optional_at_modes modes
+  | [] -> poly_type ctxt core_type f (vars, typ)
+  | _ :: _ -> pp f "%a%a" (poly_type ctxt core_type1) (vars, typ)
+      optional_at_modes modes
 
 (* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
 and binding ctxt f {pvb_pat=p; pvb_expr=x; pvb_constraint = ct; pvb_modes = modes; _} =

testsuite/tests/capsule-api/data.ml

@@ -16,8 +16,8 @@ let mk_ref : ('a -> 'a myref) @ portable = fun v -> {v}
 (* We need ['a] to be [portable] to return a [portable] value from the read.
    The return value is marked as [contended] because our callsites require that,
    but the typechecker does not implicitly downcast the result. *)
-let read_ref : (('a : value mod portable) .
-  ('a myref -> 'a @ portable contended)) @ portable = fun r -> r.v
+let read_ref : ('a : value mod portable) .
+  ('a myref -> 'a @ portable contended) @ portable = fun r -> r.v
 
 (* We need ['a] to be [portable] and [contended] to capture it in
    a [portable] closure like this.*)
@@ -177,4 +177,3 @@ let ptr' : (int, lost_capsule) Capsule.Data.t =
 let () =
   assert (Capsule.Data.project ptr' = 111)
 ;;
-

testsuite/tests/capsule-api/rwlock_capsule.ml

@@ -83,8 +83,8 @@ let with_read_guarded x (f : 'k . 'k Capsule.Password.Shared.t @ local -> ('a, '
 ;;
 
 (* reading from myref with the expected modes *)
-let read_ref : (('a : value mod portable) .
-  ('a myref @ shared -> 'a @ portable contended)) @ portable = fun r -> r.v
+let read_ref : ('a : value mod portable) .
+  ('a myref @ shared -> 'a @ portable contended) @ portable = fun r -> r.v
 
 (* writing to myref with the expected modes *)
  let write_ref : ('a : value mod portable contended) .

testsuite/tests/capsule-api/shared.ml

@@ -18,8 +18,8 @@ external reraise : exn -> 'a @ portable = "%reraise"
 type 'a myref = { mutable v : 'a }
 
 let mk_ref : ('a -> 'a myref) @ portable = fun v -> {v}
-let read_ref : (('a : value mod portable) .
-  ('a myref -> 'a @ portable contended)) @ portable = fun r -> r.v
+let read_ref : ('a : value mod portable) .
+  ('a myref -> 'a @ portable contended) @ portable = fun r -> r.v
 let write_ref : ('a : value mod portable contended) .
   'a -> ('a myref -> unit) @ portable = fun v r -> r.v <- v
 

testsuite/tests/compiler-libs/test_untypeast.ml

@@ -86,7 +86,7 @@ run {| let foo : ('a -> 'a) @ portable = fun x -> x in foo |}
 "let (foo : 'a -> 'a) = ((fun x -> x : 'a -> 'a) : _ @ portable) in foo"
 |}];;
 
-run {| let foo : ('a . 'a -> 'a) @ portable = fun x -> x in foo |}
+run {| let foo : 'a . ('a -> 'a) @ portable = fun x -> x in foo |}
 
 [%%expect{|
 - : string = "let foo : ('a : value) . 'a -> 'a = fun x -> x in foo"

testsuite/tests/parsetree/source_jane_street.ml

@@ -335,44 +335,49 @@ let f ?(local_ x = 42)
       ?(local_ x @ once portable = 42)
       ?(local_ x : int @ once portable = 42)
       ?(local_ x : ('a -> 'a) @ once portable = fun x -> x)
-      ?(local_ x : (('a : any) 'b . 'a) @ once portable = assert false)
-      ?(local_ x : (('a : any) 'b . 'a -> 'b) @ once portable = assert false)
+      ?(local_ x : ('a : any) 'b . 'a @ once portable = assert false)
+      ?(local_ x : ('a : any) 'b . 'a -> 'b @ once portable = assert false)
+      ?(local_ x : ('a : any) 'b . ('a -> 'b) @ once portable = assert false)
 
       ?x:(local_ (y, z) = 42)
       ?x:(local_ (y, z) @ once portable = 42)
       ?x:(local_ (y, z) : int @ once portable = 42)
       ?x:(local_ (y, z) : ('a -> 'a) @ once portable = 42)
-      ?x:(local_ (y, z) : (('a : any) 'b . 'a) @ once portable = 42)
-      ?x:(local_ (y, z) : (('a : any) 'b . 'a -> 'b) @ once portable = 42)
+      ?x:(local_ (y, z) : ('a : any) 'b . 'a @ once portable = 42)
+      ?x:(local_ (y, z) : ('a : any) 'b . 'a -> 'b @ once portable = 42)
+      ?x:(local_ (y, z) : ('a : any) 'b . ('a -> 'b) @ once portable = 42)
 
       ~(local_ x)
       ~(local_ x @ once portable)
       ~(local_ x : int @ once portable)
       ~(local_ x : ('a -> 'a) @ once portable)
-      ~(local_ x : (('a : any) 'b . 'a) @ once portable)
-      ~(local_ x : (('a : any) 'b . 'a -> 'b) @ once portable)
+      ~(local_ x : ('a : any) 'b . 'a @ once portable)
+      ~(local_ x : ('a : any) 'b . 'a -> 'b @ once portable)
+      ~(local_ x : ('a : any) 'b . ('a -> 'b) @ once portable)
 
       ~x:(local_ (y, z))
       ~x:(local_ (y, z) @ once portable)
       ~x:(local_ (y, z) : int @ once portable)
       ~x:(local_ (y, z) : ('a -> 'a) @ once portable)
-      ~x:(local_ (y, z) : (('a : any) 'b . 'a) @ once portable)
-      ~x:(local_ (y, z) : (('a : any) 'b . 'a -> 'b) @ once portable)
+      ~x:(local_ (y, z) : ('a : any) 'b . 'a @ once portable)
+      ~x:(local_ (y, z) : ('a : any) 'b . ('a -> 'b) @ once portable)
+      ~x:(local_ (y, z) : ('a : any) 'b . 'a -> 'b @ once portable)
 
       (local_ (y, z))
       (local_ (y, z) @ once portable)
       (local_ (y, z) : int @ once portable)
       (local_ (y, z) : ('a -> 'a) @ once portable)
-      (local_ (y, z) : (('a : any) 'b . 'a) @ once portable)
-      (local_ (y, z) : (('a : any) 'b . 'a -> 'b) @ once portable)
+      (local_ (y, z) : ('a : any) 'b . 'a @ once portable)
+      (local_ (y, z) : ('a : any) 'b . ('a -> 'b) @ once portable)
+      (local_ (y, z) : ('a : any) 'b . 'a -> 'b @ once portable)
 
       = ();;
 
 (* This file is only about syntax - type error is fine *)
 [%%expect{|
-Line 5, characters 8-55:
-5 |       ?(local_ x : (('a : any) 'b . 'a) @ once portable = assert false)
-            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Line 5, characters 8-53:
+5 |       ?(local_ x : ('a : any) 'b . 'a @ once portable = assert false)
+            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Optional parameters cannot be polymorphic
 |}]
 
@@ -392,11 +397,13 @@ let g () =
   let local_ a : int @ once portable = 42 in
   let local_ a : (int -> int) @ once portable = 42 in
 
-  let local_ a : (('a : any) 'b. 'a) @ once portable = 42 in
-  let local_ a : (('a : any) 'b. 'a -> 'a) @ once portable = 42 in
+  let local_ a : ('a : any) 'b. 'a @ once portable = 42 in
+  let local_ a : ('a : any) 'b. 'a -> 'a @ once portable = 42 in
+  let local_ a : ('a : any) 'b. ('a -> 'a) @ once portable = 42 in
 
-  let a : (type (a : any) b. int) @ once portable = 42 in
-  let a : (type (a : any) b. a -> b) @ once portable = 42 in
+  let a : type (a : any) b. int @ once portable = 42 in
+  let a : type (a : any) b. a -> b @ once portable = 42 in
+  let a : type (a : any) b. (a -> b) @ once portable = 42 in
 
   let (a, b) @ once portable = 42 in
   let (a, b) : int @ once portable = 42 in
@@ -503,8 +510,8 @@ type typvar_fn = a:('a. 'a) @ local unique portable contended -> unit
 let f ~(x1 @ many)
       ~(x2 : string @ local)
       ~(x3 : (string -> string) @ local)
-      ~(x4 : ('a. 'a -> 'a) @ local)
-      ~(x9 : ('a. 'a) @ local)
+      ~(x4 : 'a. ('a -> 'a) @ local)
+      ~(x9 : 'a. 'a @ local)
       ~(local_ x5)
       ~x6:(local_ true | false @ many)
       ~x7:(local_ true | false : bool @ many)

testsuite/tests/typing-modes/modes.ml

@@ -19,15 +19,15 @@ Line 1, characters 4-33:
 Error: This value escapes its region.
 |}]
 
-let local_ foo : ('a. 'a -> 'a) @ unique = fun x -> x
+let local_ foo : 'a. ('a -> 'a) @ unique = fun x -> x
 [%%expect{|
 Line 1, characters 4-53:
-1 | let local_ foo : ('a. 'a -> 'a) @ unique = fun x -> x
+1 | let local_ foo : 'a. ('a -> 'a) @ unique = fun x -> x
         ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This value escapes its region.
 |}]
 
-let foo : (type a. a -> a) @ unique = fun x -> x
+let foo : type a. (a -> a) @ unique = fun x -> x
 [%%expect{|
 val foo : 'a -> 'a = <fun>
 |}]
@@ -401,10 +401,10 @@ let foo ?(local_ x : _ @ unique once = 42) () = ()
 val foo : ?x:int @ local unique once -> unit -> unit = <fun>
 |}]
 
-let foo ?(local_ x : ('a. 'a -> 'a) @ unique once) = ()
+let foo ?(local_ x : 'a. ('a -> 'a) @ unique once) = ()
 [%%expect{|
 Line 1, characters 10-49:
-1 | let foo ?(local_ x : ('a. 'a -> 'a) @ unique once) = ()
+1 | let foo ?(local_ x : 'a. ('a -> 'a) @ unique once) = ()
               ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Optional parameters cannot be polymorphic
 |}]
@@ -419,10 +419,10 @@ let foo ?x:(local_ (x,y) : _ @ unique once = (42, 42)) () = ()
 val foo : ?x:int * int @ local unique once -> unit -> unit = <fun>
 |}]
 
-let foo ?x:(local_ (x,y) : ('a.'a->'a) @ unique once) () = ()
+let foo ?x:(local_ (x,y) : 'a.('a->'a) @ unique once) () = ()
 [%%expect{|
 Line 1, characters 12-52:
-1 | let foo ?x:(local_ (x,y) : ('a.'a->'a) @ unique once) () = ()
+1 | let foo ?x:(local_ (x,y) : 'a.('a->'a) @ unique once) () = ()
                 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Optional parameters cannot be polymorphic
 |}]

testsuite/tests/typing-modes/syntax-error.compilers.reference

@@ -11,7 +11,7 @@ Line 2, characters 35-36:
                                        ^
 Error: Syntax error: "mode expression" expected.
 Line 2, characters 30-31:
-2 | let foo : (type a. a -> a) @  = fun x -> x;;
+2 | let foo : type a. (a -> a) @  = fun x -> x;;
                                   ^
 Error: Syntax error: "mode expression" expected.
 Line 2, characters 13-14: