parse new local syntax, but ignore when formatting

Signed-off-by: Charlie Gunn <cgunn@janestreet.com> Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Formatting. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Add tests. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Remove code to recognize ast pattern that no longer exists. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Support modes on arrow types. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Update normalize mapper to prevent bad sugaring. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Fix ast mapper to not drop modes and modalities in various places. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Support modes on value bindings. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Add support for modes in pattern constraints and expression constraints. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Support modalities on record declarations. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Support modalities on value declarations. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Fix test; in [let (pat @ mode) = exp], the mode is actually attached to the value binding, not the pattern. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Clean up some crs Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Add tests for comments. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Fixup. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Add tests related to comments, and actually format comments. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Fix moving comment in record fields. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Revert changes which transformed old mode syntax to new mode syntax. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Add tests and make minor changes for formatting with line breaks. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Test in conjunction with old syntax. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Minor test updates. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Resolve some crs Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> resolve a cr Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Resolve cr related to comments moving around global_ Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Resolve cr. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Resolve some crs. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Add some more broken tests. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> fixup new test. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Fix formatting of tuple patterns where els have modes. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> More pattern tests. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> More pattern tests. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Remove cr related to future feature. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Resolve cr for adding more pattern tests Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Add labeled tuple pattern tests. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Fix labeled tuple pattern punning with modes. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Add more expression tests. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Fix invalid punning of labeled tuple expressions with modes. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Add more let binding tests. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Reorganize tests into modules for easier visual navigation. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Add additional sugar test. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Update comment in test. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Add tests for attributes. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Fix issue with comments after [@] and [@@]. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Miscellaneous fixes during review. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Add missing tests. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Fix modes on let-bound tuple patterns. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Fix parens around aliased patterns with modes Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Fix tuple patterns with local exprs. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com> Fix let class expressions. Signed-off-by: Thomas Del Vecchio <tdelvecchio@janestreet.com>
janestreet · Jun 20, 2024 · f998460 · f998460
1 parent 67727be
commit f998460
Show file tree

Hide file tree

Showing 33 changed files with 4,353 additions and 316 deletions.
diff --git a/lib/Ast.ml b/lib/Ast.ml
@@ -73,8 +73,8 @@ type cls = Let_match | Match | Non_apply | Sequence | Then | ThenElse
 
 module Token = struct
   let is_infix = function
-    | Parser.AMPERAMPER | AMPERSAND | ANDOP _ | BAR | BARBAR | COLON
-     |COLONCOLON | COLONEQUAL | DOTDOT | DOTOP _ | EQUAL | GREATER
+    | Parser.AMPERAMPER | AMPERSAND | ANDOP _ | AT | ATAT | BAR | BARBAR
+     |COLON | COLONCOLON | COLONEQUAL | DOTDOT | DOTOP _ | EQUAL | GREATER
      |HASHOP _ | INFIXOP0 _ | INFIXOP1 _ | INFIXOP2 _ | INFIXOP3 _
      |INFIXOP4 _ | LESS | LESSMINUS | LETOP _ | MINUS | MINUSDOT
      |MINUSGREATER | PERCENT | PLUS | PLUSDOT | PLUSEQ | SLASH | STAR ->
@@ -929,7 +929,7 @@ end = struct
     let fst_f (tI, _) = typ == tI in
     let snd_f (_, tI) = typ == tI in
     let check_cstr = function
-      | Pcstr_tuple t1N -> List.exists t1N ~f
+      | Pcstr_tuple t1N -> List.exists t1N ~f:(fun carg -> f carg.pca_type)
       | Pcstr_record (_, ld1N) ->
           List.exists ld1N ~f:(fun {pld_type; _} -> typ == pld_type)
     in
@@ -974,7 +974,7 @@ end = struct
       | Ptyp_extension _ -> ()
       | Ptyp_any | Ptyp_var _ -> assert false
       | Ptyp_alias (t1, _) | Ptyp_poly (_, t1) -> assert (typ == t1)
-      | Ptyp_arrow (t, t2) ->
+      | Ptyp_arrow (t, t2, _) ->
           assert (List.exists t ~f:(fun x -> typ == x.pap_type) || typ == t2)
       | Ptyp_tuple t1N -> assert (List.exists t1N ~f:(fun (_, t) -> f t))
       | Ptyp_constr (_, t1N) -> assert (List.exists t1N ~f)
@@ -1015,7 +1015,7 @@ end = struct
           | Pcty_signature {pcsig_self; _} -> Option.exists pcsig_self ~f )
     | Pat ctx -> (
       match ctx.ppat_desc with
-      | Ppat_constraint (_, t1) -> assert (typ == t1)
+      | Ppat_constraint (_, Some t1, _) -> assert (typ == t1)
       | Ppat_extension (_, PTyp t) -> assert (typ == t)
       | Ppat_unpack (_, Some (_, l)) ->
           assert (List.exists l ~f:(fun (_, t) -> typ == t))
@@ -1025,7 +1025,7 @@ end = struct
     | Exp ctx -> (
       match ctx.pexp_desc with
       | Pexp_pack (_, Some (_, it1N)) -> assert (List.exists it1N ~f:snd_f)
-      | Pexp_constraint (_, t1)
+      | Pexp_constraint (_, Some t1, _)
        |Pexp_coerce (_, None, t1)
        |Pexp_poly (_, Some t1)
        |Pexp_extension (_, PTyp t1) ->
@@ -1100,21 +1100,25 @@ end = struct
           | Pcf_inherit (_, _, _) -> false
           | Pcf_val (_, _, Cfk_virtual t) -> typ == t
           | Pcf_val
-              (_, _, Cfk_concrete (_, {pexp_desc= Pexp_constraint (_, t); _}))
-            ->
+              ( _
+              , _
+              , Cfk_concrete
+                  (_, {pexp_desc= Pexp_constraint (_, Some t, _); _}) ) ->
               typ == t
           | Pcf_val (_, _, Cfk_concrete _) -> false
           | Pcf_method (_, _, Cfk_virtual t) -> typ == t
           | Pcf_method
-              (_, _, Cfk_concrete (_, {pexp_desc= Pexp_constraint (_, t); _}))
-            ->
+              ( _
+              , _
+              , Cfk_concrete
+                  (_, {pexp_desc= Pexp_constraint (_, Some t, _); _}) ) ->
               typ == t
           | Pcf_method
               (_, _, Cfk_concrete (_, {pexp_desc= Pexp_poly (e, topt); _}))
             ->
               let rec loop = function
                 | {pexp_desc= Pexp_newtype (_, e); _} -> loop e
-                | {pexp_desc= Pexp_constraint (_, t); _} -> t == typ
+                | {pexp_desc= Pexp_constraint (_, Some t, _); _} -> t == typ
                 | {pexp_desc= Pexp_fun (_, e); _} -> loop e
                 | _ -> false
               in
@@ -1305,7 +1309,7 @@ end = struct
       ppat == pat
       ||
       match ppat.ppat_desc with
-      | Ppat_constraint (p, _) -> p == pat
+      | Ppat_constraint (p, _, _) -> p == pat
       | _ -> false
     in
     let check_bindings l =
@@ -1335,7 +1339,7 @@ end = struct
             assert (List.exists p1N ~f:(fun (_, _, x) -> Option.exists x ~f))
         | Ppat_or l -> assert (List.exists ~f:(fun p -> p == pat) l)
         | Ppat_alias (p1, _)
-         |Ppat_constraint (p1, _)
+         |Ppat_constraint (p1, _, _)
          |Ppat_construct (_, Some (_, p1))
          |Ppat_exception p1
          |Ppat_lazy p1
@@ -1490,7 +1494,7 @@ end = struct
         | Pexp_assert e
          |Pexp_beginend e
          |Pexp_parens e
-         |Pexp_constraint (e, _)
+         |Pexp_constraint (e, _, _)
          |Pexp_coerce (e, _, _)
          |Pexp_field (e, _)
          |Pexp_lazy e
@@ -1559,7 +1563,7 @@ end = struct
                 x == exp
                 ||
                 match x with
-                | {pexp_desc= Pexp_constraint (e, _); _} -> loop e
+                | {pexp_desc= Pexp_constraint (e, _, _); _} -> loop e
                 | _ -> false
               in
               loop e
@@ -1572,7 +1576,7 @@ end = struct
                 ||
                 match x with
                 | {pexp_desc= Pexp_newtype (_, e); _} -> loop e
-                | {pexp_desc= Pexp_constraint (e, _); _} -> loop e
+                | {pexp_desc= Pexp_constraint (e, _, _); _} -> loop e
                 | {pexp_desc= Pexp_fun (_, e); _} -> loop e
                 | _ -> false
               in
@@ -1639,12 +1643,13 @@ end = struct
     let open Prec in
     let open Assoc in
     let is_tuple_lvl1_in_constructor ty = function
-      | {pcd_args= Pcstr_tuple t1N; _} -> List.exists t1N ~f:(phys_equal ty)
+      | {pcd_args= Pcstr_tuple t1N; _} ->
+          List.exists t1N ~f:(fun carg -> carg.pca_type |> phys_equal ty)
       | _ -> false
     in
     let is_tuple_lvl1_in_ext_constructor ty = function
       | {pext_kind= Pext_decl (_, Pcstr_tuple t1N, _); _} ->
-          List.exists t1N ~f:(phys_equal ty)
+          List.exists t1N ~f:(fun carg -> carg.pca_type |> phys_equal ty)
       | _ -> false
     in
     let constructor_cxt_prec_of_inner = function
@@ -1674,7 +1679,7 @@ end = struct
     | {ctx= Str _; ast= Typ _; _} -> None
     | {ctx= Typ {ptyp_desc; _}; ast= Typ typ; _} -> (
       match ptyp_desc with
-      | Ptyp_arrow (t, _) ->
+      | Ptyp_arrow (t, _, _) ->
           let assoc =
             if List.exists t ~f:(fun x -> x.pap_type == typ) then Left
             else Right
@@ -1931,7 +1936,9 @@ end = struct
       ; ctx= Td {ptype_kind= Ptype_variant l; _} }
       when List.exists l ~f:(fun c ->
                match c.pcd_args with
-               | Pcstr_tuple l -> List.exists l ~f:(phys_equal typ)
+               | Pcstr_tuple l ->
+                   List.exists l ~f:(fun carg ->
+                       carg.pca_type |> phys_equal typ )
                | _ -> false ) ->
         true
     | { ast= {ptyp_desc= Ptyp_alias _ | Ptyp_arrow _ | Ptyp_tuple _; _}
@@ -1949,7 +1956,7 @@ end = struct
     | {ast= {ptyp_desc= Ptyp_var (_, l); _}; ctx= _} when Option.is_some l ->
         true
     | { ast= {ptyp_desc= Ptyp_tuple ((Some _, _) :: _); _}
-      ; ctx= Typ {ptyp_desc= Ptyp_arrow (args, _); _} }
+      ; ctx= Typ {ptyp_desc= Ptyp_arrow (args, _, _); _} }
       when List.exists args ~f:(fun arg -> arg.pap_type == typ) ->
         true
     | _ -> (
@@ -2013,20 +2020,40 @@ end = struct
       | _ -> true )
     | Fp {pparam_desc= Pparam_val (_, _, _, _); _}, Ppat_cons _ -> true
     | Pat {ppat_desc= Ppat_construct _; _}, Ppat_cons _ -> true
-    | Fp _, Ppat_constraint (_, {ptyp_desc= Ptyp_poly _; _}) -> true
-    | _, Ppat_constraint (_, {ptyp_desc= Ptyp_poly _; _}) -> false
+    | Fp _, Ppat_constraint (_, Some {ptyp_desc= Ptyp_poly _; _}, _) -> true
+    | _, Ppat_constraint (_, Some {ptyp_desc= Ptyp_poly _; _}, _) -> false
     | ( Exp {pexp_desc= Pexp_letop _; _}
       , ( Ppat_construct (_, Some _)
         | Ppat_cons _
         | Ppat_variant (_, Some _)
         | Ppat_or _ | Ppat_alias _
-        | Ppat_constraint ({ppat_desc= Ppat_any; _}, _) ) ) ->
+        | Ppat_constraint ({ppat_desc= Ppat_any; _}, _, _)
+        | Ppat_constraint (_, _, _ :: _) ) ) ->
         true
-    | Lb _, Ppat_constraint ({ppat_desc= Ppat_any; _}, _) -> true
-    | Lb _, Ppat_constraint ({ppat_desc= Ppat_tuple _; _}, _) -> false
+    | Lb _, Ppat_constraint ({ppat_desc= Ppat_any; _}, _, _) -> true
+    | Lb _, Ppat_constraint ({ppat_desc= Ppat_tuple _; _}, _, _) -> false
     | ( Exp {pexp_desc= Pexp_letop _; _}
-      , Ppat_constraint ({ppat_desc= Ppat_tuple _; _}, _) ) ->
+      , Ppat_constraint ({ppat_desc= Ppat_tuple _; _}, _, _) ) ->
         false
+    (* Modes on elements of let-bound tuple patterns require the tuple to be
+       parenthesized *)
+    | (Str _ | Exp _ | Cl _), Ppat_tuple (els, _)
+      when List.exists els ~f:(function
+             | _, {ppat_desc= Ppat_constraint (_, None, _ :: _); _} -> true
+             | _ -> false ) ->
+        true
+    (* Modes on let-bound tuple patterns require the tuple to be
+       parenthesized *)
+    | ( ( Str {pstr_desc= Pstr_value bindings; _}
+        | Exp {pexp_desc= Pexp_let (bindings, _); _}
+        | Cl {pcl_desc= Pcl_let (bindings, _); _} )
+      , Ppat_tuple _ )
+      when let binding =
+             List.find_exn bindings.pvbs_bindings ~f:(fun binding ->
+                 binding.pvb_pat == pat )
+           in
+           not (List.is_empty binding.pvb_modes) ->
+        true
     | _, Ppat_constraint _
      |_, Ppat_unpack _
      |( Pat
@@ -2320,7 +2347,7 @@ end = struct
          |Pexp_open (_, e)
          |Pexp_fun (_, e)
          |Pexp_newtype (_, e)
-         |Pexp_constraint (e, _)
+         |Pexp_constraint (e, _, _)
          |Pexp_coerce (e, _, _)
           when e == exp ->
             false
@@ -2424,7 +2451,7 @@ end = struct
     | Exp {pexp_desc= Pexp_indexop_access {pia_kind= Builtin idx; _}; _}, _
       when idx == exp ->
         false
-    | ( Exp {pexp_desc= Pexp_constraint (e, _) | Pexp_coerce (e, _, _); _}
+    | ( Exp {pexp_desc= Pexp_constraint (e, _, _) | Pexp_coerce (e, _, _); _}
       , {pexp_desc= Pexp_tuple _ | Pexp_match _ | Pexp_try _; _} )
       when e == exp && !ocp_indent_compat ->
         true

diff --git a/lib/Exposed.ml b/lib/Exposed.ml
@@ -14,7 +14,7 @@ open Extended_ast
 module Left = struct
   let rec core_type typ =
     match typ.ptyp_desc with
-    | Ptyp_arrow (t :: _, _) -> core_type t.pap_type
+    | Ptyp_arrow (t :: _, _, _) -> core_type t.pap_type
     | Ptyp_tuple l -> (
       match List.hd_exn l with
       | Some _, _ -> false
@@ -31,7 +31,7 @@ module Right = struct
     | {ptyp_attributes= _ :: _; _} -> false
     | {ptyp_desc; _} -> (
       match ptyp_desc with
-      | Ptyp_arrow (_, t) -> core_type t
+      | Ptyp_arrow (_, t, []) -> core_type t
       | Ptyp_tuple l -> (
         match List.last_exn l with
         | Some _, _ -> false
@@ -43,12 +43,17 @@ module Right = struct
     | Pcstr_record _ -> false
     | Pcstr_tuple args -> (
       match List.last args with
-      | Some {ptyp_desc= Ptyp_arrow _; _} ->
+      | Some {pca_modalities= _ :: _; _} ->
+          (* Modalities are the right-most part of a construct argument:
+
+             type a = A of t * u @@ modality *)
+          false
+      | Some {pca_type= {ptyp_desc= Ptyp_arrow _; _}; _} ->
           (* Arrows are wrapped in parens in this position:
 
              type a = A of (t -> <..>) *)
           false
-      | Some last -> core_type last
+      | Some {pca_type; _} -> core_type pca_type
       | None -> false )
 
   let extension_constructor = function

diff --git a/lib/Extended_ast.ml b/lib/Extended_ast.ml
@@ -80,7 +80,8 @@ module Parse = struct
                   ( { pexp_desc= Pexp_ident {txt= v_txt; _}
                     ; pexp_attributes= []
                     ; _ }
-                  , t1 )
+                  , Some t1
+                  , [] )
             ; pexp_attributes= []
             ; _ } )
         when enable_short_field_annot
@@ -94,7 +95,8 @@ module Parse = struct
                   ( { pexp_desc= Pexp_ident {txt= v_txt; _}
                     ; pexp_attributes= []
                     ; _ }
-                  , t1 )
+                  , Some t1
+                  , [] )
             ; pexp_attributes= []
             ; _ } )
         when enable_short_field_annot
@@ -147,7 +149,8 @@ module Parse = struct
                   ( { ppat_desc= Ppat_var {txt= v_txt; _}
                     ; ppat_attributes= []
                     ; _ }
-                  , t )
+                  , Some t
+                  , [] )
             ; ppat_attributes= []
             ; _ } )
         when enable_short_field_annot
@@ -182,7 +185,8 @@ module Parse = struct
       | { ppat_desc=
             Ppat_constraint
               ( {ppat_desc= Ppat_unpack (name, None); ppat_attributes= []; _}
-              , {ptyp_desc= Ptyp_package pt; ptyp_attributes= []; _} )
+              , Some {ptyp_desc= Ptyp_package pt; ptyp_attributes= []; _}
+              , [] )
         ; _ } as p ->
           {p with ppat_desc= Ppat_unpack (name, Some pt)}
       | p -> Ast_mapper.default_mapper.pat m p
@@ -228,8 +232,12 @@ module Parse = struct
                 ; pexp_attributes= []
                 ; pexp_loc
                 ; _ }
-              , {ptyp_desc= Ptyp_package pt; ptyp_attributes= []; ptyp_loc; _}
-              )
+              , Some
+                  { ptyp_desc= Ptyp_package pt
+                  ; ptyp_attributes= []
+                  ; ptyp_loc
+                  ; _ }
+              , [] )
         ; _ } as p
         when Migrate_ast.Location.compare_start ptyp_loc pexp_loc > 0 ->
           (* Match locations to differentiate between the two position for