Support for OCaml 5.3 effect syntax

CHANGES.md

@@ -13,6 +13,9 @@ 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 (#2562, @Zeta611)
+  Adds support for effect patterns.
+
 - Documentation comments are now formatted by default (#2390, @Julow)
   Use the option `parse-docstrings = false` to restore the previous behavior.
 

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

@@ -1315,10 +1315,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/dune.inc

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

test/passing/tests/effects.ml

@@ -0,0 +1,62 @@
+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 begin
+      let task = Queue.pop run_q in
+      task ()
+    end
+  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 ->
+        begin match !exchanger with
+        | Some (n', k') -> exchanger := None; enqueue k' n; continue k n'
+        | None -> exchanger := Some (n, k); dequeue ()
+        end
+  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/tests/effects.ml.ref

@@ -0,0 +1,61 @@
+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

vendor/parser-extended/ast_helper.ml

@@ -111,6 +111,7 @@ module Pat = struct
   let unpack ?loc ?attrs a b = mk ?loc ?attrs (Ppat_unpack (a, b))
   let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b))
   let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a)
+  let effect_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_effect(a, b))
   let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a)
   let cons ?loc ?attrs a = mk ?loc ?attrs (Ppat_cons a)
 end
@@ -560,7 +561,6 @@ module Te = struct
      pext_loc = loc;
      pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
     }
-
 end
 
 module Csig = struct

vendor/parser-extended/ast_mapper.ml

@@ -709,6 +709,8 @@ module P = struct
         unpack ~loc ~attrs (map_loc sub s) (map_opt (map_package_type sub) pt)
     | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p)
     | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p)
+    | Ppat_effect(p1, p2) ->
+        effect_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2)
     | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x)
     | Ppat_cons pl -> cons ~loc ~attrs (List.map (sub.pat sub) pl)
 end

vendor/parser-extended/lexer.mll

@@ -47,6 +47,7 @@ let keyword_table =
     "do", DO;
     "done", DONE;
     "downto", DOWNTO;
+    "effect", EFFECT;
     "else", ELSE;
     "end", END;
     "exception", EXCEPTION;

vendor/parser-extended/parser.mly

@@ -634,6 +634,7 @@ let mk_directive ~loc name arg =
 %token DOTDOT                 ".."
 %token DOWNTO                 "downto"
 %token ELSE                   "else"
+%token EFFECT                 "effect"
 %token END                    "end"
 %token EOF                    ""
 %token EQUAL                  "="
@@ -2822,6 +2823,8 @@ pattern:
       { $1 }
   | EXCEPTION ext_attributes pattern %prec prec_constr_appl
       { mkpat_attrs ~loc:$sloc (Ppat_exception $3) $2}
+  | EFFECT pattern_gen COMMA simple_pattern
+      { mkpat ~loc:$sloc (Ppat_effect($2,$4)) }
 ;
 
 pattern_no_exn:
@@ -2874,6 +2877,7 @@ pattern_gen:
   | LAZY ext_attributes simple_pattern
       { mkpat_attrs ~loc:$sloc (Ppat_lazy $3) $2}
 ;
+
 simple_pattern:
     mkpat(mkrhs(val_ident) %prec below_EQUAL
       { Ppat_var ($1) })

vendor/parser-extended/parsetree.mli

@@ -285,6 +285,7 @@ and pattern_desc =
             - [(module _ : S)] when [p] is [None] and [s] is [Some "S"]
          *)
   | Ppat_exception of pattern  (** Pattern [exception P] *)
+  | Ppat_effect of pattern * pattern (* Pattern [effect P P] *)
   | Ppat_extension of extension  (** Pattern [[%id]] *)
   | Ppat_open of Longident.t loc * pattern  (** Pattern [M.(P)] *)
   | Ppat_cons of pattern list  (** Pattern [P1 :: ... :: Pn] *)

vendor/parser-extended/printast.ml

@@ -323,6 +323,10 @@ and pattern i ppf x =
   | Ppat_exception p ->
       line i ppf "Ppat_exception\n";
       pattern i ppf p
+  | Ppat_effect(p1, p2) ->
+      line i ppf "Ppat_effect\n";
+      pattern i ppf p1;
+      pattern i ppf p2
   | Ppat_open (m,p) ->
       line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m;
       pattern i ppf p

vendor/parser-standard/ast_helper.ml

@@ -167,6 +167,7 @@ module Pat = struct
   let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a)
   let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b))
   let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a)
+  let effect_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_effect(a, b))
   let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a)
 end
 
@@ -608,7 +609,6 @@ module Te = struct
      pext_loc = loc;
      pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
     }
-
 end
 
 module Csig = struct

vendor/parser-standard/ast_mapper.ml

@@ -555,6 +555,8 @@ module P = struct
     | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s)
     | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p)
     | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p)
+    | Ppat_effect (p1, p2) ->
+        effect_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2)
     | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x)
 end
 

vendor/parser-standard/lexer.mll

@@ -47,6 +47,7 @@ let keyword_table =
     "do", DO;
     "done", DONE;
     "downto", DOWNTO;
+    "effect", EFFECT;
     "else", ELSE;
     "end", END;
     "exception", EXCEPTION;

vendor/parser-standard/parser.mly

@@ -736,6 +736,7 @@ let mk_directive ~loc name arg =
 %token DOT                    "."
 %token DOTDOT                 ".."
 %token DOWNTO                 "downto"
+%token EFFECT                 "effect"
 %token ELSE                   "else"
 %token END                    "end"
 %token EOF                    ""
@@ -2877,6 +2878,8 @@ pattern:
       { $1 }
   | EXCEPTION ext_attributes pattern %prec prec_constr_appl
       { mkpat_attrs ~loc:$sloc (Ppat_exception $3) $2}
+  | EFFECT pattern_gen COMMA simple_pattern
+      { mkpat ~loc:$sloc (Ppat_effect($2,$4)) }
 ;
 
 pattern_no_exn:
@@ -2922,6 +2925,7 @@ pattern_gen:
   | LAZY ext_attributes simple_pattern
       { mkpat_attrs ~loc:$sloc (Ppat_lazy $3) $2}
 ;
+
 simple_pattern:
     mkpat(mkrhs(val_ident) %prec below_EQUAL
       { Ppat_var ($1) })

vendor/parser-standard/parsetree.mli

@@ -270,6 +270,7 @@ and pattern_desc =
            [Ppat_constraint(Ppat_unpack(Some "P"), Ptyp_package S)]
          *)
   | Ppat_exception of pattern  (** Pattern [exception P] *)
+  | Ppat_effect of pattern * pattern (* Pattern [effect P P] *)
   | Ppat_extension of extension  (** Pattern [[%id]] *)
   | Ppat_open of Longident.t loc * pattern  (** Pattern [M.(P)] *)
 

vendor/parser-standard/printast.ml

@@ -242,6 +242,10 @@ and pattern i ppf x =
   | Ppat_exception p ->
       line i ppf "Ppat_exception\n";
       pattern i ppf p
+  | Ppat_effect(p1, p2) ->
+      line i ppf "Ppat_effect\n";
+      pattern i ppf p1;
+      pattern i ppf p2
   | Ppat_open (m,p) ->
       line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m;
       pattern i ppf p