Support for OCaml 5.3 effect syntax (#2562)

Author: Zeta611

CHANGES.md

@@ -14,8 +14,8 @@ profile. This started with version 0.26.0.
   This might change the formatting of some functions due to the formatting code
   being completely rewritten.
 
-- Support OCaml 5.3 syntax (#2609, #2610, #2611, #2622, #2623, @Julow)
-  This adds support for short functor type arguments syntax and utf8
+- Support OCaml 5.3 syntax (#2609, #2610, #2611, #2622, #2623, #2562, @Julow, @Zeta611)
+  This adds support for effect patterns, short functor type arguments and utf8
   identifiers.
   To format code using the new `effect` syntax, add this option to your
   `.ocamlformat`:

lib/Ast.ml

@@ -1251,6 +1251,7 @@ end = struct
          |Ppat_open (_, p1)
          |Ppat_variant (_, Some p1) ->
             assert (p1 == pat)
+        | Ppat_effect (p1, p2) -> assert (p1 == pat || p2 == pat)
         | Ppat_extension (_, ext) -> assert (check_extensions ext)
         | Ppat_any | Ppat_constant _
          |Ppat_construct (_, None)
@@ -1944,8 +1945,9 @@ end = struct
       , Ppat_tuple _ )
      |( ( Pat
             { ppat_desc=
-                ( Ppat_construct _ | Ppat_exception _ | Ppat_or _
-                | Ppat_lazy _ | Ppat_tuple _ | Ppat_variant _ | Ppat_list _ )
+                ( Ppat_construct _ | Ppat_exception _ | Ppat_effect _
+                | Ppat_or _ | Ppat_lazy _ | Ppat_tuple _ | Ppat_variant _
+                | Ppat_list _ )
             ; _ }
         | Exp {pexp_desc= Pexp_function (_, _, Pfunction_body _); _} )
       , Ppat_alias _ )
@@ -1955,25 +1957,27 @@ end = struct
         | Ppat_or _ ) )
      |( Pat
           { ppat_desc=
-              ( Ppat_construct _ | Ppat_exception _ | Ppat_tuple _
-              | Ppat_variant _ | Ppat_list _ )
+              ( Ppat_construct _ | Ppat_exception _ | Ppat_effect _
+              | Ppat_tuple _ | Ppat_variant _ | Ppat_list _ )
           ; _ }
       , Ppat_or _ )
      |Pat {ppat_desc= Ppat_lazy _; _}, Ppat_tuple _
      |Pat {ppat_desc= Ppat_tuple _; _}, Ppat_tuple _
      |Pat _, Ppat_lazy _
      |Pat _, Ppat_exception _
+     |Pat _, Ppat_effect _
      |Cl {pcl_desc= Pcl_fun _; _}, Ppat_variant (_, Some _)
      |Cl {pcl_desc= Pcl_fun _; _}, Ppat_tuple _
      |Cl {pcl_desc= Pcl_fun _; _}, Ppat_construct _
      |Cl {pcl_desc= Pcl_fun _; _}, Ppat_alias _
      |Cl {pcl_desc= Pcl_fun _; _}, Ppat_lazy _
-     |(Exp {pexp_desc= Pexp_letop _; _} | Bo _), Ppat_exception _ ->
+     |( (Exp {pexp_desc= Pexp_letop _; _} | Bo _)
+      , (Ppat_exception _ | Ppat_effect _) ) ->
         true
     | (Str _ | Exp _ | Lb _), Ppat_lazy _ -> true
     | ( (Fpe _ | Fpc _)
       , ( Ppat_tuple _ | Ppat_construct _ | Ppat_alias _ | Ppat_variant _
-        | Ppat_lazy _ | Ppat_exception _ | Ppat_or _ ) )
+        | Ppat_lazy _ | Ppat_exception _ | Ppat_effect _ | Ppat_or _ ) )
      |( Pat {ppat_desc= Ppat_construct _ | Ppat_variant _; _}
       , (Ppat_construct (_, Some _) | Ppat_cons _ | Ppat_variant (_, Some _))
       ) ->

lib/Fmt_ast.ml

@@ -1322,10 +1322,21 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
            $ fmt_extension_suffix c ext
            $ space_break
            $ fmt_pattern c (sub_pat ~ctx pat) ) )
+  | Ppat_effect (pat1, pat2) ->
+      cbox 2
+        (Params.parens_if parens c.conf
+           ( str "effect"
+           $ fmt_extension_suffix c ext
+           $ space_break
+           $ fmt_pattern c (sub_pat ~ctx pat1)
+           $ str ", "
+           $ fmt_pattern c (sub_pat ~ctx pat2) ) )
   | Ppat_extension
       ( ext
       , PPat
-          ( ( { ppat_desc= Ppat_lazy _ | Ppat_unpack _ | Ppat_exception _
+          ( ( { ppat_desc=
+                  ( Ppat_lazy _ | Ppat_unpack _ | Ppat_exception _
+                  | Ppat_effect _ )
               ; ppat_loc
               ; ppat_attributes= []
               ; _ } as pat )

test/passing/gen/dune.inc

@@ -1433,6 +1433,21 @@
  (alias runtest)
  (action (diff docstrings_toplevel_directives.mlt.err docstrings_toplevel_directives.mlt.stderr)))
 
+(rule
+ (deps .ocamlformat dune-project)
+ (action
+  (with-stdout-to effects.ml.stdout
+   (with-stderr-to effects.ml.stderr
+     (run %{bin:ocamlformat} --name effects.ml --margin-check --ocaml-version=5.3 %{dep:../tests/effects.ml})))))
+
+(rule
+ (alias runtest)
+ (action (diff effects.ml.ref effects.ml.stdout)))
+
+(rule
+ (alias runtest)
+ (action (diff effects.ml.err effects.ml.stderr)))
+
 (rule
  (deps .ocamlformat dune-project)
  (action
@@ -3727,6 +3742,21 @@
  (alias runtest)
  (action (diff pre42_syntax.ml.err pre42_syntax.ml.stderr)))
 
+(rule
+ (deps .ocamlformat dune-project)
+ (action
+  (with-stdout-to pre53_syntax.ml.stdout
+   (with-stderr-to pre53_syntax.ml.stderr
+     (run %{bin:ocamlformat} --name pre53_syntax.ml --margin-check --ocaml-version=5.2 %{dep:../tests/pre53_syntax.ml})))))
+
+(rule
+ (alias runtest)
+ (action (diff pre53_syntax.ml.ref pre53_syntax.ml.stdout)))
+
+(rule
+ (alias runtest)
+ (action (diff pre53_syntax.ml.err pre53_syntax.ml.stderr)))
+
 (rule
  (deps .ocamlformat dune-project)
  (action

test/passing/refs.default/effects.ml.ref

@@ -0,0 +1,63 @@
+let step (f : unit -> 'a) () : 'a status =
+  match f () with
+  | v -> Complete v
+  | effect Xchg msg, cont -> Suspended { msg; cont }
+
+(* A concurrent round-robin scheduler *)
+let run (main : unit -> unit) : unit =
+  let exchanger : (int * (int, unit) continuation) option ref =
+    ref None (* waiting exchanger *)
+  in
+  let run_q = Queue.create () in
+  (* scheduler queue *)
+  let enqueue k v =
+    let task () = continue k v in
+    Queue.push task run_q
+  in
+  let dequeue () =
+    if Queue.is_empty run_q then () (* done *)
+    else
+      let task = Queue.pop run_q in
+      task ()
+  in
+  let rec spawn (f : unit -> unit) : unit =
+    match f () with
+    | () -> dequeue ()
+    | exception e ->
+        print_endline (Printexc.to_string e);
+        dequeue ()
+    | effect Yield, k ->
+        enqueue k ();
+        dequeue ()
+    | effect Fork f, k ->
+        enqueue k ();
+        spawn f
+    | effect Xchg n, k -> (
+        match !exchanger with
+        | Some (n', k') ->
+            exchanger := None;
+            enqueue k' n;
+            continue k n'
+        | None ->
+            exchanger := Some (n, k);
+            dequeue ())
+  in
+  spawn main
+
+let invert (type a) ~(iter : (a -> unit) -> unit) : a Seq.t =
+  let module M = struct
+    type _ Effect.t += Yield : a -> unit t
+  end in
+  let yield v = perform (M.Yield v) in
+  fun () ->
+    match iter yield with
+    | () -> Seq.Nil
+    | effect M.Yield v, k -> Seq.Cons (v, continue k)
+
+type _ Effect.t += E : int t | F : string t
+
+let foo () = perform F
+let bar () = try foo () with effect E, k -> failwith "impossible"
+let baz () = try bar () with effect F, k -> continue k "Hello, world!";;
+
+try perform (Xchg 0) with effect Xchg n, k -> continue k 21 + continue k 21

test/passing/refs.default/pre53_syntax.ml.ref

@@ -0,0 +1,5 @@
+(** The [effect] keyword was added in OCaml 5.3. *)
+
+type effect = effect
+
+let effect effect : effect = effect

test/passing/refs.janestreet/effects.ml.ref

@@ -0,0 +1,77 @@
+let step (f : unit -> 'a) () : 'a status =
+  match f () with
+  | v -> Complete v
+  | effect Xchg msg, cont -> Suspended { msg; cont }
+;;
+
+(* A concurrent round-robin scheduler *)
+let run (main : unit -> unit) : unit =
+  let exchanger : (int * (int, unit) continuation) option ref =
+    ref None (* waiting exchanger *)
+  in
+  let run_q = Queue.create () in
+  (* scheduler queue *)
+  let enqueue k v =
+    let task () = continue k v in
+    Queue.push task run_q
+  in
+  let dequeue () =
+    if Queue.is_empty run_q
+    then () (* done *)
+    else (
+      let task = Queue.pop run_q in
+      task ())
+  in
+  let rec spawn (f : unit -> unit) : unit =
+    match f () with
+    | () -> dequeue ()
+    | exception e ->
+      print_endline (Printexc.to_string e);
+      dequeue ()
+    | effect Yield, k ->
+      enqueue k ();
+      dequeue ()
+    | effect Fork f, k ->
+      enqueue k ();
+      spawn f
+    | effect Xchg n, k ->
+      (match !exchanger with
+       | Some (n', k') ->
+         exchanger := None;
+         enqueue k' n;
+         continue k n'
+       | None ->
+         exchanger := Some (n, k);
+         dequeue ())
+  in
+  spawn main
+;;
+
+let invert (type a) ~(iter : (a -> unit) -> unit) : a Seq.t =
+  let module M = struct
+    type _ Effect.t += Yield : a -> unit t
+  end
+  in
+  let yield v = perform (M.Yield v) in
+  fun () ->
+    match iter yield with
+    | () -> Seq.Nil
+    | effect M.Yield v, k -> Seq.Cons (v, continue k)
+;;
+
+type _ Effect.t += E : int t | F : string t
+
+let foo () = perform F
+
+let bar () =
+  try foo () with
+  | effect E, k -> failwith "impossible"
+;;
+
+let baz () =
+  try bar () with
+  | effect F, k -> continue k "Hello, world!"
+;;
+
+try perform (Xchg 0) with
+| effect Xchg n, k -> continue k 21 + continue k 21

test/passing/refs.janestreet/pre53_syntax.ml.ref

@@ -0,0 +1,5 @@
+(** The [effect] keyword was added in OCaml 5.3. *)
+
+type effect = effect
+
+let effect effect : effect = effect

test/passing/refs.ocamlformat/effects.ml.ref

@@ -0,0 +1,68 @@
+let step (f : unit -> 'a) () : 'a status =
+  match f () with
+  | v ->
+      Complete v
+  | effect Xchg msg, cont ->
+      Suspended {msg; cont}
+
+(* A concurrent round-robin scheduler *)
+let run (main : unit -> unit) : unit =
+  let exchanger : (int * (int, unit) continuation) option ref =
+    ref None (* waiting exchanger *)
+  in
+  let run_q = Queue.create () in
+  (* scheduler queue *)
+  let enqueue k v =
+    let task () = continue k v in
+    Queue.push task run_q
+  in
+  let dequeue () =
+    if Queue.is_empty run_q then () (* done *)
+    else
+      let task = Queue.pop run_q in
+      task ()
+  in
+  let rec spawn (f : unit -> unit) : unit =
+    match f () with
+    | () ->
+        dequeue ()
+    | exception e ->
+        print_endline (Printexc.to_string e) ;
+        dequeue ()
+    | effect Yield, k ->
+        enqueue k () ; dequeue ()
+    | effect Fork f, k ->
+        enqueue k () ; spawn f
+    | effect Xchg n, k -> (
+      match !exchanger with
+      | Some (n', k') ->
+          exchanger := None ;
+          enqueue k' n ;
+          continue k n'
+      | None ->
+          exchanger := Some (n, k) ;
+          dequeue () )
+  in
+  spawn main
+
+let invert (type a) ~(iter : (a -> unit) -> unit) : a Seq.t =
+  let module M = struct
+    type _ Effect.t += Yield : a -> unit t
+  end in
+  let yield v = perform (M.Yield v) in
+  fun () ->
+    match iter yield with
+    | () ->
+        Seq.Nil
+    | effect M.Yield v, k ->
+        Seq.Cons (v, continue k)
+
+type _ Effect.t += E : int t | F : string t
+
+let foo () = perform F
+
+let bar () = try foo () with effect E, k -> failwith "impossible"
+
+let baz () = try bar () with effect F, k -> continue k "Hello, world!" ;;
+
+try perform (Xchg 0) with effect Xchg n, k -> continue k 21 + continue k 21

test/passing/refs.ocamlformat/pre53_syntax.ml.ref

@@ -0,0 +1,5 @@
+(** The [effect] keyword was added in OCaml 5.3. *)
+
+type effect = effect
+
+let effect effect : effect = effect