From f055dfcf240d330eb1bd7a2c7ba3f0fb6c51772a Mon Sep 17 00:00:00 2001 From: Jay Lee Date: Sat, 22 Jun 2024 17:05:18 +0900 Subject: [PATCH 1/3] Rudimentary support for effect syntax --- lib/Ast.ml | 14 +++++++++----- lib/Fmt_ast.ml | 13 ++++++++++++- vendor/parser-extended/ast_helper.ml | 2 +- vendor/parser-extended/ast_mapper.ml | 2 ++ vendor/parser-extended/lexer.mll | 1 + vendor/parser-extended/parser.mly | 4 ++++ vendor/parser-extended/parsetree.mli | 1 + vendor/parser-extended/printast.ml | 4 ++++ vendor/parser-standard/ast_helper.ml | 2 +- vendor/parser-standard/ast_mapper.ml | 2 ++ vendor/parser-standard/lexer.mll | 1 + vendor/parser-standard/parser.mly | 4 ++++ vendor/parser-standard/parsetree.mli | 1 + vendor/parser-standard/printast.ml | 4 ++++ 14 files changed, 47 insertions(+), 8 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index 47b7af461d..e5c54ce738 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -1239,6 +1239,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) @@ -1898,8 +1899,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_fun _; _} ) , Ppat_alias _ ) @@ -1909,14 +1911,15 @@ 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 _ |Exp {pexp_desc= Pexp_fun _; _}, Ppat_or _ |Cl {pcl_desc= Pcl_fun _; _}, Ppat_variant (_, Some _) |Cl {pcl_desc= Pcl_fun _; _}, Ppat_tuple _ @@ -1924,6 +1927,7 @@ end = struct |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_effect _ |( Exp {pexp_desc= Pexp_fun _; _} , ( Ppat_construct _ | Ppat_cons _ | Ppat_lazy _ | Ppat_tuple _ | Ppat_variant _ ) ) -> @@ -1931,7 +1935,7 @@ end = struct | (Str _ | Exp _), 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 _)) ) -> diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 183d6bd636..e6792b667f 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1284,10 +1284,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 ) diff --git a/vendor/parser-extended/ast_helper.ml b/vendor/parser-extended/ast_helper.ml index a245df0856..1908452357 100644 --- a/vendor/parser-extended/ast_helper.ml +++ b/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 @@ -561,7 +562,6 @@ module Te = struct pext_loc = loc; pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); } - end module Csig = struct diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml index 66f72c1ab8..446c94aa76 100644 --- a/vendor/parser-extended/ast_mapper.ml +++ b/vendor/parser-extended/ast_mapper.ml @@ -680,6 +680,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 diff --git a/vendor/parser-extended/lexer.mll b/vendor/parser-extended/lexer.mll index c6713eca47..989c1022d0 100644 --- a/vendor/parser-extended/lexer.mll +++ b/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; diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly index 5fb12a2710..a6b989fe03 100644 --- a/vendor/parser-extended/parser.mly +++ b/vendor/parser-extended/parser.mly @@ -572,6 +572,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 "=" @@ -2668,6 +2669,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: @@ -2720,6 +2723,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) }) diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli index 82f3ce85bc..d190180ab4 100644 --- a/vendor/parser-extended/parsetree.mli +++ b/vendor/parser-extended/parsetree.mli @@ -284,6 +284,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] *) diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml index e8306a21e8..5ea393231c 100644 --- a/vendor/parser-extended/printast.ml +++ b/vendor/parser-extended/printast.ml @@ -322,6 +322,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 diff --git a/vendor/parser-standard/ast_helper.ml b/vendor/parser-standard/ast_helper.ml index df8bb75691..574a14348d 100644 --- a/vendor/parser-standard/ast_helper.ml +++ b/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 @@ -605,7 +606,6 @@ module Te = struct pext_loc = loc; pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); } - end module Csig = struct diff --git a/vendor/parser-standard/ast_mapper.ml b/vendor/parser-standard/ast_mapper.ml index 1f7397480f..3fedb0ad57 100644 --- a/vendor/parser-standard/ast_mapper.ml +++ b/vendor/parser-standard/ast_mapper.ml @@ -516,6 +516,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 diff --git a/vendor/parser-standard/lexer.mll b/vendor/parser-standard/lexer.mll index dcaa9d89d1..29fbaa7633 100644 --- a/vendor/parser-standard/lexer.mll +++ b/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; diff --git a/vendor/parser-standard/parser.mly b/vendor/parser-standard/parser.mly index a38d377845..0e115b5f27 100644 --- a/vendor/parser-standard/parser.mly +++ b/vendor/parser-standard/parser.mly @@ -669,6 +669,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 "" @@ -2742,6 +2743,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: @@ -2787,6 +2790,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) }) diff --git a/vendor/parser-standard/parsetree.mli b/vendor/parser-standard/parsetree.mli index a2e28d09e0..85268eec43 100644 --- a/vendor/parser-standard/parsetree.mli +++ b/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)] *) diff --git a/vendor/parser-standard/printast.ml b/vendor/parser-standard/printast.ml index b2f23c26a8..f400e34d6d 100644 --- a/vendor/parser-standard/printast.ml +++ b/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 From d9c2782d7bc0270fd431e909c28ea81a1219a33e Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 4 Nov 2024 10:58:44 +0100 Subject: [PATCH 2/3] tests: Add effect examples from the manual --- test/passing/dune.inc | 18 +++++++++ test/passing/tests/effects.ml | 62 +++++++++++++++++++++++++++++++ test/passing/tests/effects.ml.ref | 61 ++++++++++++++++++++++++++++++ 3 files changed, 141 insertions(+) create mode 100644 test/passing/tests/effects.ml create mode 100644 test/passing/tests/effects.ml.ref diff --git a/test/passing/dune.inc b/test/passing/dune.inc index 9a1f00a0cc..bf8dda8312 100644 --- a/test/passing/dune.inc +++ b/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) diff --git a/test/passing/tests/effects.ml b/test/passing/tests/effects.ml new file mode 100644 index 0000000000..d415c5b1be --- /dev/null +++ b/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 diff --git a/test/passing/tests/effects.ml.ref b/test/passing/tests/effects.ml.ref new file mode 100644 index 0000000000..be57686e47 --- /dev/null +++ b/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 From 4c700975fff9a747091706e3fd5c09126642170f Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 4 Nov 2024 11:05:18 +0100 Subject: [PATCH 3/3] Update CHANGES --- CHANGES.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index fe535f4b8c..94b2884f4e 100644 --- a/CHANGES.md +++ b/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.