Repatch parser-standard to flambda-backend/main (#82)

lib/Normalize_std_ast.ml

@@ -16,10 +16,6 @@ let is_doc = function
   | {attr_name= {Location.txt= "ocaml.doc" | "ocaml.text"; _}; _} -> true
   | _ -> false
 
-let is_builtin_jane_syntax attr =
-  let name = attr.attr_name.txt in
-  String.is_prefix ~prefix:"jane.erasable._builtin" name
-
 let is_erasable_jane_syntax attr =
   let name = attr.attr_name.txt in
   String.is_prefix ~prefix:"jane.erasable." name
@@ -50,7 +46,7 @@ let normalize_immediate_annot_and_attrs attrs =
             , PStr
                 [ { pstr_desc=
                       Pstr_attribute
-                        { attr_name= {txt= "jane.erasable.layouts.prim"; _}
+                        { attr_name= {txt= "jane.erasable.layouts.abbrev"; _}
                         ; attr_payload=
                             PStr
                               [ { pstr_desc=
@@ -70,7 +66,7 @@ let normalize_immediate_annot_and_attrs attrs =
             , PStr
                 [ { pstr_desc=
                       Pstr_attribute
-                        { attr_name= {txt= "jane.erasable.layouts.prim"; _}
+                        { attr_name= {txt= "jane.erasable.layouts.abbrev"; _}
                         ; attr_payload=
                             PStr
                               [ { pstr_desc=
@@ -216,61 +212,116 @@ let make_mapper conf ~ignore_doc_comments ~erase_jane_syntax =
       }
     in
     let {pexp_desc; pexp_loc= loc1; pexp_attributes= attrs1; _} = exp in
-    match pexp_desc with
-    | Pexp_apply
-        ( {pexp_desc= Pexp_extension ({txt= "extension.exclave"; _}, _); _}
-        , [(Nolabel, expr)] )
-      when erase_jane_syntax ->
-        m.expr m expr
-    | Pexp_poly ({pexp_desc= Pexp_constraint (e, Some t, []); _}, None) ->
-        m.expr m {exp with pexp_desc= Pexp_poly (e, Some t)}
-    | Pexp_constraint (exp1, None, _ :: _) when erase_jane_syntax ->
-        (* When erasing jane syntax, if [Pexp_constraint] was only
-           constraining based on modes, remove the node entirely instead of
-           just making the modes list empty *)
-        m.expr m exp1
-    | Pexp_constraint (e, Some {ptyp_desc= Ptyp_poly ([], _t); _}, []) ->
-        m.expr m e
-    | Pexp_sequence
-        ( exp1
-        , { pexp_desc= Pexp_sequence (exp2, exp3)
-          ; pexp_loc= loc2
-          ; pexp_attributes= attrs2
-          ; _ } ) ->
+    match Jane_syntax.Expression.of_ast exp with
+    | Some
+        ( Jexp_layout
+            (Lexp_newtype
+              (l, jkind, {pexp_desc= Pexp_constraint (exp1, Some ty, []); _})
+              )
+        , attrs ) ->
+        (* CR jane-syntax: Special case where we transform a jane syntax
+           expression into a non-jane syntax expression, since jkind
+           annotations are in the parsetree for [Pparam_newtype] but not
+           [Pexp_newtype] *)
+        (* See comment on [Pexp_newtype] below *)
         m.expr m
-          (Exp.sequence ~loc:loc1 ~attrs:attrs1
-             (Exp.sequence ~loc:loc2 ~attrs:attrs2 exp1 exp2)
-             exp3 )
-    | Pexp_fun
-        ( Labelled l
-        , None
-        , { ppat_desc=
-              Ppat_constraint
-                ( pat
-                , Some
-                    {ptyp_desc= Ptyp_extension ({txt= "call_pos"; loc}, _); _}
-                , _ )
-          ; _ }
-        , expression )
-      when erase_jane_syntax ->
-        let default_pos = dummy_position ~loc in
-        let expression =
-          let pexp_desc =
-            Pexp_fun (Optional l, Some default_pos, pat, expression)
+          { exp with
+            pexp_attributes= attrs
+          ; pexp_desc=
+              Pexp_function
+                ( [ { pparam_loc= l.loc
+                    ; pparam_desc= Pparam_newtype (l, Some jkind) } ]
+                , Some {mode_annotations= []; type_constraint= Pconstraint ty}
+                , Pfunction_body exp1 ) }
+    | _ -> (
+      match pexp_desc with
+      | Pexp_apply
+          ( {pexp_desc= Pexp_extension ({txt= "extension.exclave"; _}, _); _}
+          , [(Nolabel, expr)] )
+        when erase_jane_syntax ->
+          m.expr m expr
+      | Pexp_poly ({pexp_desc= Pexp_constraint (e, Some t, []); _}, None) ->
+          m.expr m {exp with pexp_desc= Pexp_poly (e, Some t)}
+      | Pexp_constraint (exp1, None, _ :: _) when erase_jane_syntax ->
+          (* When erasing jane syntax, if [Pexp_constraint] was only
+             constraining based on modes, remove the node entirely instead of
+             just making the modes list empty *)
+          m.expr m exp1
+      | Pexp_constraint (e, Some {ptyp_desc= Ptyp_poly ([], _t); _}, []) ->
+          m.expr m e
+      | Pexp_sequence
+          ( exp1
+          , { pexp_desc= Pexp_sequence (exp2, exp3)
+            ; pexp_loc= loc2
+            ; pexp_attributes= attrs2
+            ; _ } ) ->
+          m.expr m
+            (Exp.sequence ~loc:loc1 ~attrs:attrs1
+               (Exp.sequence ~loc:loc2 ~attrs:attrs2 exp1 exp2)
+               exp3 )
+      | Pexp_function
+          ( ps
+          , c
+          , Pfunction_body {pexp_desc= Pexp_function (ps', None, b'); _} ) ->
+          m.expr m {exp with pexp_desc= Pexp_function (ps @ ps', c, b')}
+      | Pexp_newtype (l, {pexp_desc= Pexp_constraint (exp1, Some ty, []); _})
+        ->
+          (* This is a hack. Our version of ocamlformat rewrites [fun (type
+             a) -> (function x -> x)] into [fun (type a) -> function x -> x],
+             but these two things parse differently by design. We shouldn't
+             do this, but have decided to avoid making ocamlformat work
+             sanely for syntactic function arity until upstream does. We
+             should delete this, and other similar bits of normalization,
+             when we merge with 5.2 ocamlforamt. *)
+          m.expr m
+            { exp with
+              pexp_desc=
+                Pexp_function
+                  ( [ { pparam_loc= l.loc
+                      ; pparam_desc= Pparam_newtype (l, None) } ]
+                  , Some
+                      {mode_annotations= []; type_constraint= Pconstraint ty}
+                  , Pfunction_body exp1 ) }
+      | Pexp_function
+          ( ps
+          , c
+          , Pfunction_body {pexp_desc= Pexp_constraint (exp1, Some ty, []); _}
+          )
+        when Option.is_none c ->
+          let c =
+            Some {mode_annotations= []; type_constraint= Pconstraint ty}
           in
-          {exp with pexp_desc}
-        in
-        m.expr m expression
-    | Pexp_extension ({txt= "src_pos"; loc}, _) when erase_jane_syntax ->
-        m.expr m (dummy_position ~loc)
-    | Pexp_fun _ | Pexp_function _ | Pexp_newtype _ ->
-        (* CR jane-syntax: This just ignores N_ary functions, and can be
-           removed when ocamlformat stops messing with them *)
-        let attrs1 =
-          List.filter ~f:(fun a -> not (is_builtin_jane_syntax a)) attrs1
-        in
-        Ast_mapper.default_mapper.expr m {exp with pexp_attributes= attrs1}
-    | _ -> Ast_mapper.default_mapper.expr m exp
+          m.expr m
+            {exp with pexp_desc= Pexp_function (ps, c, Pfunction_body exp1)}
+      | Pexp_function (ps, c, b) when erase_jane_syntax ->
+          let ps =
+            List.map ps ~f:(fun param ->
+                match param.pparam_desc with
+                | Pparam_newtype (x, Some _) ->
+                    {param with pparam_desc= Pparam_newtype (x, None)}
+                | Pparam_val
+                    ( Labelled l
+                    , None
+                    , { ppat_desc=
+                          Ppat_constraint
+                            ( pat
+                            , Some
+                                { ptyp_desc=
+                                    Ptyp_extension ({txt= "call_pos"; loc}, _)
+                                ; _ }
+                            , _ )
+                      ; _ } ) ->
+                    let default_pos = dummy_position ~loc in
+                    { param with
+                      pparam_desc=
+                        Pparam_val (Optional l, Some default_pos, pat) }
+                | _ -> param )
+          in
+          Ast_mapper.default_mapper.expr m
+            {exp with pexp_desc= Pexp_function (ps, c, b)}
+      | Pexp_extension ({txt= "src_pos"; loc}, _) when erase_jane_syntax ->
+          m.expr m (dummy_position ~loc)
+      | _ -> Ast_mapper.default_mapper.expr m exp )
   in
   let pat (m : Ast_mapper.mapper) pat =
     let pat = {pat with ppat_loc_stack= []} in

test/passing/dune.inc

@@ -4301,6 +4301,42 @@
  (package ocamlformat)
  (action (diff tests/fun_function.ml.js-err fun_function.ml.js-stderr)))
 
+(rule
+ (deps tests/.ocamlformat )
+ (package ocamlformat)
+ (action
+  (with-stdout-to function_constraint.ml.stdout
+   (with-stderr-to function_constraint.ml.stderr
+     (run %{bin:ocamlformat} --margin-check --max-iters=5 %{dep:tests/function_constraint.ml})))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/function_constraint.ml.ref function_constraint.ml.stdout)))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/function_constraint.ml.err function_constraint.ml.stderr)))
+
+(rule
+ (deps tests/.ocamlformat )
+ (package ocamlformat)
+ (action
+  (with-stdout-to function_constraint.ml.js-stdout
+   (with-stderr-to function_constraint.ml.js-stderr
+     (run %{bin:ocamlformat} --profile=janestreet --enable-outside-detected-project --disable-conf-files %{dep:tests/function_constraint.ml})))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/function_constraint.ml.js-ref function_constraint.ml.js-stdout)))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/function_constraint.ml.js-err function_constraint.ml.js-stderr)))
+
 (rule
  (deps tests/.ocamlformat )
  (package ocamlformat)

test/passing/tests/function_constraint.ml

@@ -0,0 +1,133 @@
+(* RHS annotated with a type *)
+let f (type a) = (() : unit)
+let (* 1 *) f (* 2 *) (type a) (* 3 *) = (* 4 *)
+  (* 5 *) ((* 6 *) () (* 7 *) : (* 8 *) unit (* 9 *)) (* 10 *)
+let[@a1] f (type a) = (()[@a2] : unit[@a3])
+
+let f (type a : immediate) = (() : unit)
+let (* 1 *) f (type a (* 2 *) : (* 3 *) immediate (* 4 *)) (* 5 *) = (* 6 *)
+  (* 7 *) ( (* 8 *) () (* 9 *) : (* 10 *) unit (* 11 *) ) (* 12 *)
+let[@a1] f (type a : immediate) = (()[@a2] : unit[@a3])
+
+let f x y = (() : unit)
+let (* 1 *) f (* 2 *) x (* 3 *) y (* 4 *) =
+  (* 5 *) ((* 6 *)() (* 7 *) : (* 8 *) unit (* 9 *)) (* 10 *)
+let[@a1] f (x[@a2]) (y[@a3]) = (()[@a4] : unit[@a5])
+
+(* RHS annotated with a type and mode *)
+let f (type a) = (() : unit @@ local)
+let (* 1 *) f (* 2 *) ((* 3 *) type (* 4 *) a (* 5 *)) (* 6 *) = (* 7 *)
+  (* 8 *) ( (* 9 *) () : (* 10 *) unit (* 11 *) @@ (* 12 *) local (* 13 *) )
+let[@a1] f (type a) = (()[@a2] : unit [@a3] @@ local)
+
+let f (type a : value) = (() : unit @@ local)
+let (* 1 *) f (* 2 *) ((* 3 *) type (* 4 *) a (* 5 *) : (* 6 *) value (* 7 *)) (* 8 *) =
+  (* 9 *) ((* 10 *) () (* 11 *) : (* 12 *) unit (* 13 *) @@ (* 14 *) local (* 15 *))
+  (* 16 *)
+let[@a1] f (type a : value) = (()[@a2] : unit[@a3] @@ local)
+
+let f x y = (() : unit @@ local)
+let (* 1 *) f (* 2 *) x (* 3 *) y (* 4 *) = (* 5 *)
+  ((* 6 *) () (* 7 *) : (* 8 *) unit (* 9 *) @@ (* 10 *) local (* 11 *)) (* 12 *)
+let[@a1] f (x[@a2]) (y[@a3]) = (()[@a4] : unit[@a5] @@ local)
+
+(* LHS and RHS annotated with the same type *)
+let f (type a) : unit = (() : unit)
+let (* 1 *) f (* 2 *) ((* 3 *) type (* 4 *) a (* 5 *)) (* 6 *) : (* 7 *) unit (* 8 *) =
+  (* 9 *) ((* 10 *) () (* 11 *) : (* 12 *) unit (* 13 *)) (* 14 *)
+let[@a1] f (type a) : unit[@a2] = (()[@a3] : unit[@a4])
+
+let f (type a : value) : unit = (() : unit)
+let (* 1 *) f (* 2 *) ((* 3 *) type (* 4 *) a (* 5 *) : (* 6 *) value (* 7 *)) (* 8 *)
+  : (* 9 *) unit (* 10 *) =
+  (* 11 *) ((* 12 *) () (* 13 *) : (* 14 *) unit (* 15 *)) (* 16 *)
+let[@a1] f (type a : value) : unit[@a2] = (()[@a3] : unit[@a4])
+
+let f x y : unit = (() : unit)
+let (* 1 *) f (* 2 *) x (* 3 *) y (* 4 *) : (* 5 *) unit (* 6 *) =
+  (* 7 *) ((* 8 *) () (* 9 *) : (* 10 *) unit (* 11 *)) (* 12 *)
+let[@a1] f (x[@a2]) (y[@a3]) : unit[@a4] = (()[@a5] : unit[@a6])
+
+(* LHS and RHS annotated with different types *)
+let f (type a) : unit = (() : int)
+let (* 1 *) f (* 2 *) ((* 3 *) type (* 4 *) a (* 5 *)) (* 6 *) : (* 7 *) unit (* 8 *) =
+  (* 9 *) ((* 10 *) () (* 11 *) : (* 12 *) int (* 13 *)) (* 14 *)
+let[@a1] f (type a) : unit[@a2] = (()[@a3] : int[@a4])
+
+let f (type a : value) : unit = (() : int)
+let (* 1 *) f (* 2 *) ((* 3 *) type (* 4 *) a (* 5 *) : (* 6 *) value (* 7 *)) (* 8 *)
+  : (* 9 *) unit (* 10 *) =
+  (* 11 *) ((* 12 *) () (* 13 *) : (* 14 *) int (* 15 *)) (* 16 *)
+let[@a1] f (type a : value) : unit[@a2] = (()[@a3] : int[@a4])
+
+let f x y : unit = (() : int)
+let (* 1 *) f (* 2 *) x (* 3 *) y (* 4 *) : (* 5 *) unit (* 6 *) =
+  (* 7 *) ( (* 8 *) () (* 9 *) : (* 10 *) int (* 11 *) ) (* 12 *)
+let[@a1] f (x[@a2]) (y[@a3]) : unit[@a4] = (()[@a5] : int[@a6])
+
+(* LHS annotated with a mode, RHS annotated with a type *)
+let (f @ local) (type a) = (() : unit)
+let (* 1 *) ((* 2 *) f (* 3 *) @ (* 4 *) local (* 5 *))
+              (* 6 *) ((* 7 *) type (* 8 *) a (* 9 *) ) (* 10 *) =
+  (* 11 *) ((* 12 *) () (* 13 *) : (* 14 *) unit (* 15 *)) (* 16 *)
+let[@a1] (f @ local) (type a) = (()[@a2] : unit[@a3])
+
+let (f @ local) (type a : value) = (() : unit)
+let (* 1 *) ((* 2 *) f (* 3 *) @ (* 4 *) local (* 5 *)) (* 6 *)
+              ((* 7 *) type (* 8 *) a (* 9 *) : (* 10 *) value (* 11 *)) (* 12 *) =
+  (* 13 *) ((* 14 *) () (* 15 *) : (* 16 *) unit (* 17 *)) (* 18 *)
+let[@a1] (f @ local) (type a : value) = (()[@a2] : unit[@a3])
+
+let (f @ local) x y  = (() : unit)
+let (* 1 *) ((* 2 *) f (* 3 *) @ (* 4 *) local (* 5 *)) (* 6 *) x (* 7 *) y (* 8 *) =
+  (* 9 *) ((* 10 *) () (* 11 *) : (* 12 *) unit (* 13 *) ) (* 14 *)
+let[@a1] (f @ local) (x[@a2]) (y[@a3]) = (()[@a4] : unit[@a5])
+
+(* Nested funs *)
+let _ = f (fun x -> fun y -> z)
+let (* 1 *) _ (* 2 *) =
+  (* 3 *) f (* 4 *) ((* 5 *) fun (* 6 *) x (* 7 *) ->
+  (* 8 *) fun (* 9 *) y (* 10 *) -> (* 11 *) z (* 12 *) ) (* 13 *)
+let[@a1] _ = (f[@a2]) (fun (x[@a3]) -> fun (y[@a4]) -> z[@a5])
+
+let _ = f (fun x : unit -> fun y -> z)
+let (* 1 *) _ (* 2 *) =
+  (* 3 *) f (* 4 *) ((* 5 *) fun (* 6 *) x (* 7 *) : (* 8 *) unit (* 9 *) ->
+  (* 10 *) fun (* 11 *) y (* 12 *) -> (* 13 *) z (* 14 *)) (* 15 *)
+let[@a1] _ = (f[@a2]) (fun (x[@a3]) : (unit[@a4]) -> fun (y[@a5]) -> z[@a6])
+
+let _ = f (fun x -> fun y : unit -> z)
+let (* 1 *) _ (* 2 *) =
+  (* 3 *) f (* 4 *) ((* 5*) fun (* 6 *) x (* 7 *) ->
+  (* 8 *) fun (* 9 *) y (* 10 *) : (* 11 *) unit (* 12 *) -> (* 13 *) z (* 14 *)) (* 15 *)
+let[@a1] _ = (f[@a2]) (fun (x[@a3]) -> fun (y[@a4]) : (unit[@a5]) -> z[@a6])
+
+let _ = f (fun x : unit -> fun y : unit -> z)
+let (* 1 *) _ (* 2 *) =
+  (* 3 *) f (* 4 *) ((* 5*) fun (* 6 *) x (* 7 *) : (* 8 *) unit (* 9 *) ->
+  (* 10 *) fun (* 11 *) y (* 12 *) : (* 13 *) unit (* 14 *) -> (* 15 *) z)
+  (* 17 *)
+let[@a1] _ = (f[@a2]) (fun (x[@a3]) : (unit[@a4]) -> fun (y[@a5]) : (unit[@a6]) -> z[@a7])
+
+(* CR: Some of the comment movement above are kind of sad. For
+   example this:
+     let f (* 2 *) (type (* 3 *) a) = (() : unit @@ local)
+   becomes:
+     let f (type (* 3 *) a) = (* 2 *) (() : unit @@ local)
+
+   Why does (* 2 *) get moved out to the rhs? *)
+
+(* CR: there is a live bug that drops [@a4] in examples like
+
+     let f (type a) = (() : unit) [@a4]
+
+   Add that attribute back to the relevant examples in this file once the bug is fixed.
+*)
+(* CR the last comments test in this file seems to hit some scale limitation.  If you add
+   back the "missing" (* 16 *) after [z], ocamlformat hits its iteration limit:
+
+let (* 1 *) _ (* 2 *) =
+  (* 3 *) f (* 4 *) ((* 5*) fun (* 6 *) x (* 7 *) : (* 8 *) unit (* 9 *) ->
+  (* 10 *) fun (* 11 *) y (* 12 *) : (* 13 *) unit (* 14 *) -> (* 15 *) z (* 16 *))
+  (* 17 *)
+*)

test/passing/tests/function_constraint.ml.err

@@ -0,0 +1,4 @@
+Warning: tests/function_constraint.ml:307 exceeds the margin
+Warning: tests/function_constraint.ml:309 exceeds the margin
+Warning: tests/function_constraint.ml:310 exceeds the margin
+Warning: tests/function_constraint.ml:314 exceeds the margin