├── test ├── dune.inc ├── errors │ ├── dangling.ml │ ├── rebind.ml │ ├── invalid_payload_type_in_try.ml │ ├── match_without_value_case.ml │ ├── invalid_payload_type_in_match.ml │ ├── malformed_payload.ml │ ├── double_when_guard.ml │ ├── malformed_payload_hint_missing_comma.ml │ ├── rebind.expected │ ├── double_when_guard.expected │ ├── match_without_value_case.expected │ ├── malformed_payload.expected │ ├── invalid_payload_type_in_try.expected │ ├── invalid_payload_type_in_match.expected │ ├── malformed_payload_hint_missing_comma.expected │ ├── dangling.expected │ ├── dune │ └── dune.inc ├── dune ├── passing │ ├── shadowed_raise.ml │ ├── exhaustive_handlers.ml │ ├── when_guards.ml │ ├── main.ml │ ├── dune │ ├── shadowed_raise.expected │ ├── scrutinee.ml │ ├── when_guards.expected │ ├── exhaustive_handlers.expected │ ├── main.expected │ ├── scrutinee.expected │ └── dune.inc └── gen_dune_rules.ml ├── .gitignore ├── src ├── ppx_effects.mli ├── dune ├── ppx_effects_runtime.ml └── ppx_effects.ml ├── .ocamlformat ├── main.ml ├── dune-project ├── ppx_effects.opam └── README.md /test/dune.inc: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | _opam 3 | -------------------------------------------------------------------------------- /test/errors/dangling.ml: -------------------------------------------------------------------------------- 1 | let () = [%effect E] 2 | -------------------------------------------------------------------------------- /test/errors/rebind.ml: -------------------------------------------------------------------------------- 1 | exception%effect E = E 2 | -------------------------------------------------------------------------------- /src/ppx_effects.mli: -------------------------------------------------------------------------------- 1 | (* Intentionally empty *) 2 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name gen_dune_rules) 3 | (modules gen_dune_rules)) 4 | -------------------------------------------------------------------------------- /test/errors/invalid_payload_type_in_try.ml: -------------------------------------------------------------------------------- 1 | let () = try () with [%effect ()] -> () 2 | -------------------------------------------------------------------------------- /test/errors/match_without_value_case.ml: -------------------------------------------------------------------------------- 1 | let () = match () with [%effect? _] -> () 2 | -------------------------------------------------------------------------------- /test/errors/invalid_payload_type_in_match.ml: -------------------------------------------------------------------------------- 1 | let () = match () with [%effect ()] -> () 2 | -------------------------------------------------------------------------------- /test/errors/malformed_payload.ml: -------------------------------------------------------------------------------- 1 | let () = try f () with [%effect? E (* missing [, k] *)] -> () 2 | -------------------------------------------------------------------------------- /test/errors/double_when_guard.ml: -------------------------------------------------------------------------------- 1 | let () = try f () with [%effect? E, k when true] when false -> () 2 | -------------------------------------------------------------------------------- /test/passing/shadowed_raise.ml: -------------------------------------------------------------------------------- 1 | let raise = `shadowed 2 | let () = match () with () -> () | [%effect? _] -> () 3 | -------------------------------------------------------------------------------- /test/errors/malformed_payload_hint_missing_comma.ml: -------------------------------------------------------------------------------- 1 | let () = try f () with [%effect? E (* missing [,] *) k] -> () 2 | -------------------------------------------------------------------------------- /test/errors/rebind.expected: -------------------------------------------------------------------------------- 1 | File "rebind.ml", line 1, characters 0-22: 2 | Error: ppx_effects: cannot process effect defined as an alias of ‘E’. 3 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.24.1 2 | profile = conventional 3 | break-infix = fit-or-vertical 4 | parse-docstrings = true 5 | module-item-spacing = compact -------------------------------------------------------------------------------- /test/errors/double_when_guard.expected: -------------------------------------------------------------------------------- 1 | File "double_when_guard.ml", line 1, characters 23-48: 2 | Error: ppx_effects: cannot specify ‘when’ both inside and outside the [%effect? ...] node. 3 | -------------------------------------------------------------------------------- /test/errors/match_without_value_case.expected: -------------------------------------------------------------------------------- 1 | File "match_without_value_case.ml", line 1, characters 9-41: 2 | Error: ppx_effects: none of the patterns in this ‘match’ expression match values. 3 | -------------------------------------------------------------------------------- /test/errors/malformed_payload.expected: -------------------------------------------------------------------------------- 1 | File "malformed_payload.ml", line 1, characters 23-55: 2 | Error: ppx_effects: invalid [%effect? ...] payload. Expected a pattern for an (eff, continuation) pair, e.g. ‘[%effect? Foo, k]’. 3 | -------------------------------------------------------------------------------- /test/errors/invalid_payload_type_in_try.expected: -------------------------------------------------------------------------------- 1 | File "invalid_payload_type_in_try.ml", line 1, characters 21-33: 2 | Error: ppx_effects: invalid node ‘[%effect ]’ used as a pattern. 3 | Hint: did you mean to use ‘[%effect? ]’ instead? 4 | -------------------------------------------------------------------------------- /test/errors/invalid_payload_type_in_match.expected: -------------------------------------------------------------------------------- 1 | File "invalid_payload_type_in_match.ml", line 1, characters 23-35: 2 | Error: ppx_effects: invalid node ‘[%effect ]’ used as a pattern. 3 | Hint: did you mean to use ‘[%effect? ]’ instead? 4 | -------------------------------------------------------------------------------- /test/errors/malformed_payload_hint_missing_comma.expected: -------------------------------------------------------------------------------- 1 | File "malformed_payload_hint_missing_comma.ml", line 1, characters 23-55: 2 | Error: ppx_effects: invalid [%effect? ...] payload. Expected a pattern for an (eff, continuation) pair. 3 | Hint: did you mean ‘[%effect? E, k]’? 4 | -------------------------------------------------------------------------------- /test/errors/dangling.expected: -------------------------------------------------------------------------------- 1 | File "dangling.ml", line 1, characters 11-17: 2 | Error: ppx_effects: dangling [%effect ...] extension node. This node may be used as: 3 | - the top level of ‘match’ or ‘try’ patterns as ‘[%effect? ...]’ 4 | - on an exception definition as ‘exception%effect ...’. 5 | -------------------------------------------------------------------------------- /main.ml: -------------------------------------------------------------------------------- 1 | type _ eff += E : tring eff 2 | 3 | let comp () = 4 | print_string "0 "; 5 | print_string (perform E); 6 | print_string "3 " 7 | 8 | let raise f = f 9 | 10 | let main () = 11 | try comp () 12 | with [%effect? E, _] -> 13 | print_string "1 "; 14 | continue k "2 "; 15 | print_string "4 " 16 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_effects_runtime) 3 | (public_name ppx_effects.runtime) 4 | (modules ppx_effects_runtime)) 5 | 6 | (library 7 | (public_name ppx_effects) 8 | (modules :standard \ ppx_effects_runtime) 9 | (kind ppx_rewriter) 10 | (ppx_runtime_libraries ppx_effects_runtime) 11 | (libraries ppxlib) 12 | (preprocess 13 | (pps ppxlib.metaquot))) 14 | -------------------------------------------------------------------------------- /test/passing/exhaustive_handlers.ml: -------------------------------------------------------------------------------- 1 | (* Tests in which the exception and effect handlers provided by the user handle 2 | all possible types of [exn] and [eff] respectively. *) 3 | 4 | let run_and_discard_effect f a = 5 | match f a with () -> () | [%effect? _, _] -> () 6 | 7 | let run_and_discard_both f a = 8 | match f a with () -> () | [%effect? _, _] -> () | exception _ -> () 9 | -------------------------------------------------------------------------------- /test/passing/when_guards.ml: -------------------------------------------------------------------------------- 1 | exception%effect Foo : bool -> unit 2 | 3 | let _ = 4 | match false with 5 | | _ when true -> 'a' 6 | | _ -> 'b' 7 | | exception Not_found -> 'c' 8 | | exception Failure s when String.equal s "Oops" -> 'd' 9 | | [%effect? Foo b, _] when b -> 'e' 10 | | [%effect? Foo b, _ when not b] -> 'e' 11 | | [%effect? Foo _, k] -> Effect.Deep.continue k () 12 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.9) 2 | (generate_opam_files true) 3 | 4 | (name ppx_effects) 5 | (source (github CraigFe/ppx_effects)) 6 | (license MIT) 7 | (authors "Craig Ferguson") 8 | (maintainers "me@craigfe.io") 9 | 10 | (package 11 | (name ppx_effects) 12 | (synopsis "PPX syntax for untyped effects in OCaml 5.0") 13 | (description "PPX syntax for untyped effects in OCaml 5.0") 14 | (documentation "https://craigfe.github.io/ppx-effects") 15 | (depends 16 | (ocaml-variants (= 4.12.0+domains)) 17 | (ppxlib (and (>= 0.12.0))))) -------------------------------------------------------------------------------- /test/passing/main.ml: -------------------------------------------------------------------------------- 1 | open Stdlib.Effect 2 | open Stdlib.Effect.Deep 3 | 4 | exception%effect E : string 5 | 6 | let comp () = 7 | print_string "0 "; 8 | print_string (perform E); 9 | print_string "3 " 10 | 11 | let () = 12 | try comp () 13 | with [%effect? E, k] -> 14 | print_string "1 "; 15 | continue k "2 "; 16 | print_string "4 " 17 | 18 | let () = 19 | match comp () with 20 | | e -> e 21 | | [%effect? E, k] -> 22 | print_string "1 "; 23 | continue k "2 "; 24 | print_string "4 " 25 | -------------------------------------------------------------------------------- /test/passing/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets pp.ml) 3 | (action 4 | (write-file %{targets} "let () = Ppxlib.Driver.standalone ()"))) 5 | 6 | (executable 7 | (name pp) 8 | (modules pp) 9 | (libraries ppx_effects ppxlib)) 10 | 11 | (include dune.inc) 12 | 13 | (rule 14 | (targets dune.inc.gen) 15 | (deps 16 | (source_tree .)) 17 | (action 18 | (with-stdout-to 19 | %{targets} 20 | (run ../gen_dune_rules.exe)))) 21 | 22 | (rule 23 | (alias runtest) 24 | (package ppx_effects) 25 | (action 26 | (diff dune.inc dune.inc.gen))) 27 | -------------------------------------------------------------------------------- /test/passing/shadowed_raise.expected: -------------------------------------------------------------------------------- 1 | let raise = `shadowed 2 | let () = 3 | Ppx_effects_runtime.match_with (fun `unit -> ()) `unit 4 | { 5 | Ppx_effects_runtime.retc = (function | () -> ()); 6 | exnc = Ppx_effects_runtime.raise; 7 | effc = 8 | (let effc : type continue_input. 9 | continue_input Stdlib.Effect.t -> 10 | ((continue_input, _) Stdlib.Effect.Deep.continuation -> _) 11 | option 12 | = function | _ -> Some ((fun _ -> ())) in 13 | effc) 14 | } 15 | -------------------------------------------------------------------------------- /test/errors/dune: -------------------------------------------------------------------------------- 1 | (env 2 | (_ 3 | (env-vars 4 | (OCAML_ERROR_STYLE "short") 5 | (OCAML_COLOR "never")))) 6 | 7 | (rule 8 | (targets pp.ml) 9 | (action 10 | (write-file %{targets} "let () = Ppxlib.Driver.standalone ()"))) 11 | 12 | (executable 13 | (name pp) 14 | (modules pp) 15 | (libraries ppx_effects ppxlib)) 16 | 17 | (include dune.inc) 18 | 19 | (rule 20 | (targets dune.inc.gen) 21 | (deps 22 | (source_tree .)) 23 | (action 24 | (with-stdout-to 25 | %{targets} 26 | (run ../gen_dune_rules.exe --expect-failure)))) 27 | 28 | (rule 29 | (alias runtest) 30 | (package ppx_effects) 31 | (action 32 | (diff dune.inc dune.inc.gen))) 33 | -------------------------------------------------------------------------------- /src/ppx_effects_runtime.ml: -------------------------------------------------------------------------------- 1 | (** These functions are exported for use by the [ppx_effects] PPX. They are not 2 | intended to be called directly by users. *) 3 | 4 | let raise = Stdlib.raise 5 | 6 | open Stdlib.Effect.Deep 7 | 8 | type nonrec ('a, 'b) handler = ('a, 'b) handler = { 9 | retc : 'a -> 'b; 10 | exnc : exn -> 'b; 11 | effc : 'c. 'c Effect.t -> (('c, 'b) continuation -> 'b) option; 12 | } 13 | 14 | type nonrec 'a effect_handler = 'a effect_handler = { 15 | effc : 'b. 'b Effect.t -> (('b, 'a) continuation -> 'a) option; 16 | } 17 | 18 | let match_with : type a b c. (a -> b) -> a -> (b, c) handler -> c = match_with 19 | let try_with : type a b. (a -> b) -> a -> b effect_handler -> b = try_with 20 | -------------------------------------------------------------------------------- /test/passing/scrutinee.ml: -------------------------------------------------------------------------------- 1 | exception%effect E : string 2 | 3 | let f () = Stdlib.Effect.perform E 4 | let g () = f 5 | 6 | (* If the scrutinee is already of the form [f x], where [f] and [x] are both 7 | values, use [f] directly as the effect-raising function. *) 8 | let _ = try f () with [%effect? E, _] -> "" 9 | 10 | (* Negative test cases: *) 11 | 12 | (* - [f] or [x] is not a value *) 13 | let _ = try (Fun.id f) () with [%effect? E, _] -> "" 14 | let _ = try f (Fun.id ()) with [%effect? E, _] -> "" 15 | 16 | (* - the scrutinee isn't of the form [f x]: *) 17 | let _ = try g () () with [%effect? E, _] -> "" 18 | 19 | let _ = 20 | try 21 | let () = () in 22 | f () 23 | with [%effect? E, _] -> "" 24 | -------------------------------------------------------------------------------- /test/passing/when_guards.expected: -------------------------------------------------------------------------------- 1 | type _ Stdlib.Effect.t += 2 | | Foo: bool -> unit Stdlib.Effect.t 3 | let _ = 4 | Ppx_effects_runtime.match_with (fun `unit -> false) `unit 5 | { 6 | Ppx_effects_runtime.retc = (function | _ when true -> 'a' | _ -> 'b'); 7 | exnc = 8 | (function 9 | | Not_found -> 'c' 10 | | Failure s when String.equal s "Oops" -> 'd' 11 | | e -> Ppx_effects_runtime.raise e); 12 | effc = 13 | (let effc : type continue_input. 14 | continue_input Stdlib.Effect.t -> 15 | ((continue_input, _) Stdlib.Effect.Deep.continuation -> _) 16 | option 17 | = 18 | function 19 | | Foo b when b -> Some ((fun _ -> 'e')) 20 | | Foo b when not b -> Some ((fun _ -> 'e')) 21 | | Foo _ -> Some ((fun k -> Effect.Deep.continue k ())) 22 | | _ -> None in 23 | effc) 24 | } 25 | -------------------------------------------------------------------------------- /test/passing/exhaustive_handlers.expected: -------------------------------------------------------------------------------- 1 | let run_and_discard_effect f a = 2 | Ppx_effects_runtime.match_with f a 3 | { 4 | Ppx_effects_runtime.retc = (function | () -> ()); 5 | exnc = Ppx_effects_runtime.raise; 6 | effc = 7 | (let effc : type continue_input. 8 | continue_input Stdlib.Effect.t -> 9 | ((continue_input, _) Stdlib.Effect.Deep.continuation -> _) 10 | option 11 | = function | _ -> Some ((fun _ -> ())) in 12 | effc) 13 | } 14 | let run_and_discard_both f a = 15 | Ppx_effects_runtime.match_with f a 16 | { 17 | Ppx_effects_runtime.retc = (function | () -> ()); 18 | exnc = (function | _ -> ()); 19 | effc = 20 | (let effc : type continue_input. 21 | continue_input Stdlib.Effect.t -> 22 | ((continue_input, _) Stdlib.Effect.Deep.continuation -> _) 23 | option 24 | = function | _ -> Some ((fun _ -> ())) in 25 | effc) 26 | } 27 | -------------------------------------------------------------------------------- /ppx_effects.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "PPX syntax for untyped effects in OCaml 5.0" 4 | description: "PPX syntax for untyped effects in OCaml 5.0" 5 | maintainer: ["me@craigfe.io"] 6 | authors: ["Craig Ferguson"] 7 | license: "MIT" 8 | homepage: "https://github.com/CraigFe/ppx_effects" 9 | doc: "https://craigfe.github.io/ppx-effects" 10 | bug-reports: "https://github.com/CraigFe/ppx_effects/issues" 11 | depends: [ 12 | "dune" {>= "2.9"} 13 | "ocaml-variants" {= "4.12.0+domains"} 14 | "ppxlib" {>= "0.12.0"} 15 | "odoc" {with-doc} 16 | ] 17 | build: [ 18 | ["dune" "subst"] {dev} 19 | [ 20 | "dune" 21 | "build" 22 | "-p" 23 | name 24 | "-j" 25 | jobs 26 | "--promote-install-files=false" 27 | "@install" 28 | "@runtest" {with-test} 29 | "@doc" {with-doc} 30 | ] 31 | ["dune" "install" "-p" name "--create-install-files" name] 32 | ] 33 | dev-repo: "git+https://github.com/CraigFe/ppx_effects.git" 34 | -------------------------------------------------------------------------------- /test/passing/main.expected: -------------------------------------------------------------------------------- 1 | open Stdlib.Effect 2 | open Stdlib.Effect.Deep 3 | type _ Stdlib.Effect.t += 4 | | E: string Stdlib.Effect.t 5 | let comp () = print_string "0 "; print_string (perform E); print_string "3 " 6 | let () = 7 | Ppx_effects_runtime.try_with comp () 8 | { 9 | Ppx_effects_runtime.effc = 10 | (let effc : type continue_input. 11 | continue_input Stdlib.Effect.t -> 12 | ((continue_input, _) Stdlib.Effect.Deep.continuation -> _) 13 | option 14 | = 15 | function 16 | | E -> 17 | Some 18 | ((fun k -> 19 | print_string "1 "; continue k "2 "; print_string "4 ")) 20 | | _ -> None in 21 | effc) 22 | } 23 | let () = 24 | Ppx_effects_runtime.match_with comp () 25 | { 26 | Ppx_effects_runtime.retc = (function | e -> e); 27 | exnc = Ppx_effects_runtime.raise; 28 | effc = 29 | (let effc : type continue_input. 30 | continue_input Stdlib.Effect.t -> 31 | ((continue_input, _) Stdlib.Effect.Deep.continuation -> _) 32 | option 33 | = 34 | function 35 | | E -> 36 | Some 37 | ((fun k -> 38 | print_string "1 "; continue k "2 "; print_string "4 ")) 39 | | _ -> None in 40 | effc) 41 | } 42 | -------------------------------------------------------------------------------- /test/passing/scrutinee.expected: -------------------------------------------------------------------------------- 1 | type _ Stdlib.Effect.t += 2 | | E: string Stdlib.Effect.t 3 | let f () = Stdlib.Effect.perform E 4 | let g () = f 5 | let _ = 6 | Ppx_effects_runtime.try_with f () 7 | { 8 | Ppx_effects_runtime.effc = 9 | (let effc : type continue_input. 10 | continue_input Stdlib.Effect.t -> 11 | ((continue_input, _) Stdlib.Effect.Deep.continuation -> _) 12 | option 13 | = function | E -> Some ((fun _ -> "")) | _ -> None in 14 | effc) 15 | } 16 | let _ = 17 | Ppx_effects_runtime.try_with (fun `unit -> (Fun.id f) ()) `unit 18 | { 19 | Ppx_effects_runtime.effc = 20 | (let effc : type continue_input. 21 | continue_input Stdlib.Effect.t -> 22 | ((continue_input, _) Stdlib.Effect.Deep.continuation -> _) 23 | option 24 | = function | E -> Some ((fun _ -> "")) | _ -> None in 25 | effc) 26 | } 27 | let _ = 28 | Ppx_effects_runtime.try_with (fun `unit -> f (Fun.id ())) `unit 29 | { 30 | Ppx_effects_runtime.effc = 31 | (let effc : type continue_input. 32 | continue_input Stdlib.Effect.t -> 33 | ((continue_input, _) Stdlib.Effect.Deep.continuation -> _) 34 | option 35 | = function | E -> Some ((fun _ -> "")) | _ -> None in 36 | effc) 37 | } 38 | let _ = 39 | Ppx_effects_runtime.try_with (fun `unit -> g () ()) `unit 40 | { 41 | Ppx_effects_runtime.effc = 42 | (let effc : type continue_input. 43 | continue_input Stdlib.Effect.t -> 44 | ((continue_input, _) Stdlib.Effect.Deep.continuation -> _) 45 | option 46 | = function | E -> Some ((fun _ -> "")) | _ -> None in 47 | effc) 48 | } 49 | let _ = 50 | Ppx_effects_runtime.try_with (fun `unit -> let () = () in f ()) `unit 51 | { 52 | Ppx_effects_runtime.effc = 53 | (let effc : type continue_input. 54 | continue_input Stdlib.Effect.t -> 55 | ((continue_input, _) Stdlib.Effect.Deep.continuation -> _) 56 | option 57 | = function | E -> Some ((fun _ -> "")) | _ -> None in 58 | effc) 59 | } 60 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## `ppx_effects` – syntax extensions for untyped effects in OCaml 5.0 2 | 3 | OCaml 5.0 will ship with support for [_effects_][effects-tutorial]! :tada: 4 | 5 | However, since the effect implementation is currently untyped, the compiler 6 | doesn't yet provide any dedicated syntax to support defining or handling 7 | effects. This PPX provides a close approximation to the _proposed_ syntax, 8 | hopefully making it simpler to use effects in your OCaml 5.0 code (and easing 9 | future migrations to a dedicated syntax). 10 | 11 | [effects-tutorial]: https://github.com/ocamllabs/ocaml-effects-tutorial 12 | 13 | **STATUS: EXPERIMENTAL** 14 | 15 | [![OCaml-CI Build Status](https://img.shields.io/endpoint?url=https%3A%2F%2Fci.ocamllabs.io%2Fbadge%2FCraigFe%2Fppx_effects%2Fmain&logo=ocaml)](https://ci.ocamllabs.io/github/CraigFe/ppx_effects) 16 | 17 | ## Usage 18 | 19 | In short: 20 | 21 | - **Declaring effects**: `effect E : string -> int` is written as `exception%effect E : string -> int` 22 | - **Handling effects**: `| effect (E _) k ->` is written as `| [%effect? (E _), k] ->` 23 | 24 | See the result of porting this PPX to various effectful repositories here: 25 | 26 | - [ocaml-multicore/effects-examples](https://github.com/CraigFe/effects-examples/pull/1) 27 | - [ocamllabs/ocaml-effects-tutorial](https://github.com/CraigFe/ocaml-effects-tutorial/pull/1) 28 | 29 | ## Install 30 | 31 | This library has not yet been released to `opam`. To install it, first 32 | 33 | ``` 34 | opam pin add --yes https://github.com/CraigFe/ppx_effects.git 35 | opam install ppx_effects 36 | ``` 37 | 38 | Users of [`dune`](https://github.com/ocaml/dune/) can then use this PPX on their 39 | libraries and executables by adding the appropriate stanza field: 40 | 41 | ```lisp 42 | (library 43 | ... 44 | (preprocess (pps ppx_effects))) 45 | ``` 46 | 47 | ## Details 48 | 49 | Using the PPX should ideally be exactly like using the dedicated syntax. 50 | However, there are a few implementation details that can leak to PPX users: 51 | 52 | - the expansion of `match` / `try` expressions containing top-level `[%effect? 53 | ...]` patterns introduces a locally-abstract type named `continue_input` 54 | representing the type of values passed to `continue` (and returned from a 55 | suspended `perform`). This type name can appear in error messages, but 56 | shouldn't be referred to from user code. (If you find you _do_ need this type 57 | name for some reason, raise an issue on this repository!) 58 | 59 | - in order to use the low-level effects API provided by the compiler, an 60 | effectful computation being `match`-ed or `try`-ed must be wrapped in an 61 | allocated thunk (e.g. `fun () -> ...`). This thunk has a small performance 62 | cost, so very performance-critical code should arrange to make this expression 63 | a simple unary function application (as in, `match f x with` or `try f x 64 | with`) instead – this avoids needing to allocate the thunk. 65 | -------------------------------------------------------------------------------- /test/gen_dune_rules.ml: -------------------------------------------------------------------------------- 1 | let output_stanzas ~expect_failure filename = 2 | let base = Filename.remove_extension filename in 3 | let pp_library ppf base = 4 | (* If the PPX will fail, we don't need to declare the file as executable *) 5 | if not expect_failure then 6 | Format.fprintf ppf 7 | "; The PPX-dependent executable under test@,\ 8 | @[(executable@ (name %s)@ (modules %s)@ (preprocess (pps \ 9 | ppx_effects)))@]" 10 | base base 11 | else () 12 | in 13 | let pp_rule ppf base = 14 | let pp_action ppf expect_failure = 15 | Format.fprintf ppf 16 | (if expect_failure then 17 | "; expect the process to fail, capturing stderr@,\ 18 | @[(with-stderr-to@,\ 19 | %%{targets}@,\ 20 | (bash \"! ./%%{pp} -no-color --impl %%{input}\"))@]" 21 | else "(run ./%%{pp} --impl %%{input} -o %%{targets})") 22 | in 23 | Format.fprintf ppf 24 | "; Run the PPX on the `.ml` file@,\ 25 | @[(rule@,\ 26 | (targets %s.actual)@,\ 27 | @[(deps@,\ 28 | (:pp pp.exe)@,\ 29 | (:input %s.ml))@]@,\ 30 | @[(action@,\ 31 | %a))@]@]" 32 | base base pp_action expect_failure 33 | in 34 | let pp_diff_alias ppf base = 35 | Format.fprintf ppf 36 | "; Compare the post-processed output to the .expected file@,\ 37 | @[(rule@,\ 38 | (alias runtest)@,\ 39 | (package ppx_effects)@,\ 40 | @[(action@,\ 41 | @[(diff@ %s.expected@ %s.actual)@])@])@]" base base 42 | in 43 | let pp_run_alias ppf base = 44 | (* If we expect the derivation to succeed, then we should be able to compile 45 | the output. *) 46 | if not expect_failure then 47 | Format.fprintf ppf 48 | "@,\ 49 | @,\ 50 | ; Ensure that the post-processed executable runs correctly@,\ 51 | @[(rule@,\ 52 | (alias runtest)@,\ 53 | (package ppx_effects)@,\ 54 | @[(action@,\ 55 | @[(run@ ./%s.exe)@])@])@]" base 56 | else () 57 | in 58 | Format.set_margin 80; 59 | Format.printf "@[; -------- Test: `%s.ml` --------%a@,@,%a@,@,%a%a@,@]@." 60 | base pp_library base pp_rule base pp_diff_alias base pp_run_alias base 61 | 62 | let is_error_test = function 63 | | "pp.ml" -> false 64 | | "gen_dune_rules.ml" -> false 65 | | filename -> 66 | Filename.check_suffix filename ".ml" 67 | (* Avoid capturing post-PPX files *) 68 | && not (Filename.check_suffix filename ".pp.ml") 69 | 70 | let () = 71 | let expect_failure = 72 | match Array.to_list Sys.argv with 73 | | [ _; "--expect-failure" ] -> true 74 | | [ _ ] -> false 75 | | _ -> failwith "Unsupported option passed" 76 | in 77 | Sys.readdir "." 78 | |> Array.to_list 79 | |> List.sort String.compare 80 | |> List.filter is_error_test 81 | |> List.iter (output_stanzas ~expect_failure); 82 | Format.printf "\n%!" 83 | -------------------------------------------------------------------------------- /test/passing/dune.inc: -------------------------------------------------------------------------------- 1 | ; -------- Test: `exhaustive_handlers.ml` --------; The PPX-dependent executable under test 2 | (executable 3 | (name exhaustive_handlers) 4 | (modules exhaustive_handlers) 5 | (preprocess (pps ppx_effects))) 6 | 7 | ; Run the PPX on the `.ml` file 8 | (rule 9 | (targets exhaustive_handlers.actual) 10 | (deps 11 | (:pp pp.exe) 12 | (:input exhaustive_handlers.ml)) 13 | (action 14 | (run ./%{pp} --impl %{input} -o %{targets}))) 15 | 16 | ; Compare the post-processed output to the .expected file 17 | (rule 18 | (alias runtest) 19 | (package ppx_effects) 20 | (action 21 | (diff exhaustive_handlers.expected exhaustive_handlers.actual))) 22 | 23 | ; Ensure that the post-processed executable runs correctly 24 | (rule 25 | (alias runtest) 26 | (package ppx_effects) 27 | (action 28 | (run ./exhaustive_handlers.exe))) 29 | 30 | ; -------- Test: `main.ml` --------; The PPX-dependent executable under test 31 | (executable 32 | (name main) 33 | (modules main) 34 | (preprocess (pps ppx_effects))) 35 | 36 | ; Run the PPX on the `.ml` file 37 | (rule 38 | (targets main.actual) 39 | (deps 40 | (:pp pp.exe) 41 | (:input main.ml)) 42 | (action 43 | (run ./%{pp} --impl %{input} -o %{targets}))) 44 | 45 | ; Compare the post-processed output to the .expected file 46 | (rule 47 | (alias runtest) 48 | (package ppx_effects) 49 | (action 50 | (diff main.expected main.actual))) 51 | 52 | ; Ensure that the post-processed executable runs correctly 53 | (rule 54 | (alias runtest) 55 | (package ppx_effects) 56 | (action 57 | (run ./main.exe))) 58 | 59 | ; -------- Test: `scrutinee.ml` --------; The PPX-dependent executable under test 60 | (executable 61 | (name scrutinee) 62 | (modules scrutinee) 63 | (preprocess (pps ppx_effects))) 64 | 65 | ; Run the PPX on the `.ml` file 66 | (rule 67 | (targets scrutinee.actual) 68 | (deps 69 | (:pp pp.exe) 70 | (:input scrutinee.ml)) 71 | (action 72 | (run ./%{pp} --impl %{input} -o %{targets}))) 73 | 74 | ; Compare the post-processed output to the .expected file 75 | (rule 76 | (alias runtest) 77 | (package ppx_effects) 78 | (action 79 | (diff scrutinee.expected scrutinee.actual))) 80 | 81 | ; Ensure that the post-processed executable runs correctly 82 | (rule 83 | (alias runtest) 84 | (package ppx_effects) 85 | (action 86 | (run ./scrutinee.exe))) 87 | 88 | ; -------- Test: `shadowed_raise.ml` --------; The PPX-dependent executable under test 89 | (executable 90 | (name shadowed_raise) 91 | (modules shadowed_raise) 92 | (preprocess (pps ppx_effects))) 93 | 94 | ; Run the PPX on the `.ml` file 95 | (rule 96 | (targets shadowed_raise.actual) 97 | (deps 98 | (:pp pp.exe) 99 | (:input shadowed_raise.ml)) 100 | (action 101 | (run ./%{pp} --impl %{input} -o %{targets}))) 102 | 103 | ; Compare the post-processed output to the .expected file 104 | (rule 105 | (alias runtest) 106 | (package ppx_effects) 107 | (action 108 | (diff shadowed_raise.expected shadowed_raise.actual))) 109 | 110 | ; Ensure that the post-processed executable runs correctly 111 | (rule 112 | (alias runtest) 113 | (package ppx_effects) 114 | (action 115 | (run ./shadowed_raise.exe))) 116 | 117 | ; -------- Test: `when_guards.ml` --------; The PPX-dependent executable under test 118 | (executable 119 | (name when_guards) 120 | (modules when_guards) 121 | (preprocess (pps ppx_effects))) 122 | 123 | ; Run the PPX on the `.ml` file 124 | (rule 125 | (targets when_guards.actual) 126 | (deps 127 | (:pp pp.exe) 128 | (:input when_guards.ml)) 129 | (action 130 | (run ./%{pp} --impl %{input} -o %{targets}))) 131 | 132 | ; Compare the post-processed output to the .expected file 133 | (rule 134 | (alias runtest) 135 | (package ppx_effects) 136 | (action 137 | (diff when_guards.expected when_guards.actual))) 138 | 139 | ; Ensure that the post-processed executable runs correctly 140 | (rule 141 | (alias runtest) 142 | (package ppx_effects) 143 | (action 144 | (run ./when_guards.exe))) 145 | 146 | 147 | -------------------------------------------------------------------------------- /test/errors/dune.inc: -------------------------------------------------------------------------------- 1 | ; -------- Test: `dangling.ml` -------- 2 | 3 | ; Run the PPX on the `.ml` file 4 | (rule 5 | (targets dangling.actual) 6 | (deps 7 | (:pp pp.exe) 8 | (:input dangling.ml)) 9 | (action 10 | ; expect the process to fail, capturing stderr 11 | (with-stderr-to 12 | %{targets} 13 | (bash "! ./%{pp} -no-color --impl %{input}")))) 14 | 15 | ; Compare the post-processed output to the .expected file 16 | (rule 17 | (alias runtest) 18 | (package ppx_effects) 19 | (action 20 | (diff dangling.expected dangling.actual))) 21 | 22 | ; -------- Test: `double_when_guard.ml` -------- 23 | 24 | ; Run the PPX on the `.ml` file 25 | (rule 26 | (targets double_when_guard.actual) 27 | (deps 28 | (:pp pp.exe) 29 | (:input double_when_guard.ml)) 30 | (action 31 | ; expect the process to fail, capturing stderr 32 | (with-stderr-to 33 | %{targets} 34 | (bash "! ./%{pp} -no-color --impl %{input}")))) 35 | 36 | ; Compare the post-processed output to the .expected file 37 | (rule 38 | (alias runtest) 39 | (package ppx_effects) 40 | (action 41 | (diff double_when_guard.expected double_when_guard.actual))) 42 | 43 | ; -------- Test: `invalid_payload_type_in_match.ml` -------- 44 | 45 | ; Run the PPX on the `.ml` file 46 | (rule 47 | (targets invalid_payload_type_in_match.actual) 48 | (deps 49 | (:pp pp.exe) 50 | (:input invalid_payload_type_in_match.ml)) 51 | (action 52 | ; expect the process to fail, capturing stderr 53 | (with-stderr-to 54 | %{targets} 55 | (bash "! ./%{pp} -no-color --impl %{input}")))) 56 | 57 | ; Compare the post-processed output to the .expected file 58 | (rule 59 | (alias runtest) 60 | (package ppx_effects) 61 | (action 62 | (diff invalid_payload_type_in_match.expected 63 | invalid_payload_type_in_match.actual))) 64 | 65 | ; -------- Test: `invalid_payload_type_in_try.ml` -------- 66 | 67 | ; Run the PPX on the `.ml` file 68 | (rule 69 | (targets invalid_payload_type_in_try.actual) 70 | (deps 71 | (:pp pp.exe) 72 | (:input invalid_payload_type_in_try.ml)) 73 | (action 74 | ; expect the process to fail, capturing stderr 75 | (with-stderr-to 76 | %{targets} 77 | (bash "! ./%{pp} -no-color --impl %{input}")))) 78 | 79 | ; Compare the post-processed output to the .expected file 80 | (rule 81 | (alias runtest) 82 | (package ppx_effects) 83 | (action 84 | (diff invalid_payload_type_in_try.expected 85 | invalid_payload_type_in_try.actual))) 86 | 87 | ; -------- Test: `malformed_payload.ml` -------- 88 | 89 | ; Run the PPX on the `.ml` file 90 | (rule 91 | (targets malformed_payload.actual) 92 | (deps 93 | (:pp pp.exe) 94 | (:input malformed_payload.ml)) 95 | (action 96 | ; expect the process to fail, capturing stderr 97 | (with-stderr-to 98 | %{targets} 99 | (bash "! ./%{pp} -no-color --impl %{input}")))) 100 | 101 | ; Compare the post-processed output to the .expected file 102 | (rule 103 | (alias runtest) 104 | (package ppx_effects) 105 | (action 106 | (diff malformed_payload.expected malformed_payload.actual))) 107 | 108 | ; -------- Test: `malformed_payload_hint_missing_comma.ml` -------- 109 | 110 | ; Run the PPX on the `.ml` file 111 | (rule 112 | (targets malformed_payload_hint_missing_comma.actual) 113 | (deps 114 | (:pp pp.exe) 115 | (:input malformed_payload_hint_missing_comma.ml)) 116 | (action 117 | ; expect the process to fail, capturing stderr 118 | (with-stderr-to 119 | %{targets} 120 | (bash "! ./%{pp} -no-color --impl %{input}")))) 121 | 122 | ; Compare the post-processed output to the .expected file 123 | (rule 124 | (alias runtest) 125 | (package ppx_effects) 126 | (action 127 | (diff malformed_payload_hint_missing_comma.expected 128 | malformed_payload_hint_missing_comma.actual))) 129 | 130 | ; -------- Test: `match_without_value_case.ml` -------- 131 | 132 | ; Run the PPX on the `.ml` file 133 | (rule 134 | (targets match_without_value_case.actual) 135 | (deps 136 | (:pp pp.exe) 137 | (:input match_without_value_case.ml)) 138 | (action 139 | ; expect the process to fail, capturing stderr 140 | (with-stderr-to 141 | %{targets} 142 | (bash "! ./%{pp} -no-color --impl %{input}")))) 143 | 144 | ; Compare the post-processed output to the .expected file 145 | (rule 146 | (alias runtest) 147 | (package ppx_effects) 148 | (action 149 | (diff match_without_value_case.expected match_without_value_case.actual))) 150 | 151 | ; -------- Test: `rebind.ml` -------- 152 | 153 | ; Run the PPX on the `.ml` file 154 | (rule 155 | (targets rebind.actual) 156 | (deps 157 | (:pp pp.exe) 158 | (:input rebind.ml)) 159 | (action 160 | ; expect the process to fail, capturing stderr 161 | (with-stderr-to 162 | %{targets} 163 | (bash "! ./%{pp} -no-color --impl %{input}")))) 164 | 165 | ; Compare the post-processed output to the .expected file 166 | (rule 167 | (alias runtest) 168 | (package ppx_effects) 169 | (action 170 | (diff rebind.expected rebind.actual))) 171 | 172 | 173 | -------------------------------------------------------------------------------- /src/ppx_effects.ml: -------------------------------------------------------------------------------- 1 | (*———————————————————————————————————————————————————————————————————————————— 2 | Copyright (c) 2021 Craig Ferguson 3 | Distributed under the MIT license. See terms at the end of this file. 4 | ————————————————————————————————————————————————————————————————————————————*) 5 | 6 | open Ppxlib 7 | open Ast_builder.Default 8 | 9 | let namespace = "ppx_effects" 10 | let pp_quoted ppf s = Format.fprintf ppf "‘%s’" s 11 | let raise_errorf ~loc fmt = Location.raise_errorf ~loc ("%s: " ^^ fmt) namespace 12 | 13 | (** Cases of [match] / [try] can be partitioned into three categories: 14 | 15 | - exception patterns (uing the [exception] keyword); 16 | - effect patterns (written using [\[%effect? ...\]]); 17 | - return patterns (available only to [match]). 18 | 19 | The [Stdlib.Effect] API requires passing different continuations for each of 20 | these categories. *) 21 | module Cases = struct 22 | type partitioned = { ret : cases; exn : cases; eff : cases } 23 | 24 | let get_effect_payload ~loc : payload -> pattern * expression option = 25 | function 26 | | PPat (x, y) -> (x, y) 27 | | _ -> 28 | (* The user made a mistake and forgot to add [?] after [effect] (this 29 | node captures expressions rather than patterns). *) 30 | raise_errorf ~loc 31 | "invalid node %a used as a pattern.@,\ 32 | Hint: did you mean to use %a instead?" pp_quoted "[%effect ]" 33 | pp_quoted "[%effect? ]" 34 | 35 | let fold_case : 36 | map_subnodes:Ast_traverse.map -> case -> partitioned -> partitioned = 37 | fun ~map_subnodes case acc -> 38 | match case.pc_lhs with 39 | | { ppat_desc = Ppat_extension ({ txt = "effect"; _ }, payload); _ } -> ( 40 | let loc = case.pc_lhs.ppat_loc in 41 | let body, internal_guard = get_effect_payload ~loc payload in 42 | let pc_guard = 43 | match (internal_guard, case.pc_guard) with 44 | | None, None -> None 45 | | (Some _ as x), None | None, (Some _ as x) -> x 46 | | Some _, Some _ -> 47 | raise_errorf ~loc 48 | "cannot specify %a both inside and outside the [%%effect? ...] \ 49 | node." 50 | pp_quoted "when" 51 | in 52 | match body with 53 | | [%pat? [%p? eff_pattern], [%p? k_pattern]] -> 54 | let pc_rhs = 55 | let loc = case.pc_rhs.pexp_loc in 56 | [%expr 57 | Some 58 | (fun [%p k_pattern] -> 59 | [%e map_subnodes#expression case.pc_rhs])] 60 | in 61 | let case = { pc_lhs = eff_pattern; pc_rhs; pc_guard } in 62 | { acc with eff = case :: acc.eff } 63 | (* Also allow a single [_] to wildcard both effect and pattern. *) 64 | | [%pat? _] -> 65 | let pc_rhs = 66 | let loc = case.pc_rhs.pexp_loc in 67 | [%expr Some (fun _ -> [%e map_subnodes#expression case.pc_rhs])] 68 | in 69 | let case = { pc_lhs = [%pat? _]; pc_rhs; pc_guard } in 70 | { acc with eff = case :: acc.eff } 71 | (* Can't split the pattern into effect and continuation components. *) 72 | | _ -> ( 73 | let error_prefix = 74 | "invalid [%effect? ...] payload. Expected a pattern for an (eff, \ 75 | continuation) pair" 76 | in 77 | (* Maybe the user missed a comma separating the two? *) 78 | match body with 79 | | { 80 | ppat_desc = 81 | Ppat_construct 82 | ( effect, 83 | Some ([], { ppat_desc = Ppat_var { txt = "k"; _ }; _ }) ); 84 | _; 85 | } -> 86 | raise_errorf ~loc "%s.@,Hint: did you mean %a?" error_prefix 87 | pp_quoted 88 | (Printf.sprintf "[%%effect? %s, k]" 89 | (Longident.name effect.txt)) 90 | (* Otherwise, just raise a generic error. *) 91 | | _ -> 92 | raise_errorf ~loc "%s, e.g. %a." error_prefix pp_quoted 93 | "[%effect? Foo, k]")) 94 | | [%pat? exception [%p? exn_pattern]] -> 95 | let pc_rhs = map_subnodes#expression case.pc_rhs in 96 | let case = { pc_lhs = exn_pattern; pc_rhs; pc_guard = case.pc_guard } in 97 | { acc with exn = case :: acc.exn } 98 | | _ -> { acc with ret = case :: acc.ret } 99 | 100 | let partition : map_subnodes:Ast_traverse.map -> cases -> partitioned = 101 | fun ~map_subnodes cases -> 102 | ListLabels.fold_right cases 103 | ~init:{ ret = []; exn = []; eff = [] } 104 | ~f:(fold_case ~map_subnodes) 105 | 106 | let contain_effect_handler : cases -> bool = 107 | List.exists (fun case -> 108 | match case.pc_lhs.ppat_desc with 109 | | Ppat_extension ({ txt = "effect"; _ }, _) -> true 110 | | _ -> false) 111 | end 112 | 113 | (** The [Stdlib.Effect] API requires effects to happen under a function 114 | application *) 115 | module Scrutinee = struct 116 | type delayed = { function_ : expression; argument : expression } 117 | 118 | (* An expression is a syntactic value if its AST structure precludes it from 119 | raising an effect or an exception. Here we use a very simple 120 | under-approximation (avoiding multiple recursion): *) 121 | let rec expr_is_syntactic_value (expr : expression) : bool = 122 | match expr.pexp_desc with 123 | | Pexp_ident _ | Pexp_constant _ | Pexp_function _ | Pexp_fun _ 124 | | Pexp_construct (_, None) 125 | | Pexp_variant (_, None) 126 | | Pexp_field _ | Pexp_lazy _ -> 127 | true 128 | | Pexp_let _ | Pexp_apply _ | Pexp_match _ | Pexp_try _ | Pexp_tuple _ 129 | | Pexp_record _ | Pexp_setfield _ | Pexp_array _ | Pexp_ifthenelse _ 130 | | Pexp_sequence _ | Pexp_while _ | Pexp_for _ | Pexp_new _ | Pexp_override _ 131 | | Pexp_letmodule _ | Pexp_object _ | Pexp_pack _ | Pexp_letop _ 132 | | Pexp_extension _ | Pexp_unreachable -> 133 | false 134 | (* Congruence cases: *) 135 | | Pexp_constraint (e, _) 136 | | Pexp_coerce (e, _, _) 137 | | Pexp_construct (_, Some e) 138 | | Pexp_variant (_, Some e) 139 | | Pexp_send (e, _) 140 | | Pexp_setinstvar (_, e) 141 | | Pexp_letexception (_, e) 142 | | Pexp_assert e 143 | | Pexp_newtype (_, e) 144 | | Pexp_open (_, e) -> 145 | expr_is_syntactic_value e 146 | | Pexp_poly _ -> assert false 147 | 148 | let of_expression = function 149 | | [%expr [%e? function_] [%e? argument]] 150 | when expr_is_syntactic_value function_ && expr_is_syntactic_value argument 151 | -> 152 | { function_; argument } 153 | | e -> 154 | (* If the expression is not already of the form [f x] then we must 155 | allocate a thunk to delay the effect. *) 156 | let loc = e.pexp_loc in 157 | (* NOTE: here we use [`unit] over [()] in case the user has 158 | shadowed the unit constructor. *) 159 | let function_ = [%expr fun `unit -> [%e e]] in 160 | let argument = [%expr `unit] in 161 | { function_; argument } 162 | end 163 | 164 | (* Both [exnc] and [effc] require a noop case to represent an unhandled 165 | exception or effect respectively. [exnc] reraises the unhandled exception, 166 | and [effc] returns None. 167 | 168 | Caveat: it's possible that a noop case is not needed becuase the user's 169 | handler is exhaustive, resulting in an unwanted "redundant case" warning. 170 | We get around this by checking whether the users' cases are syntactically 171 | exhaustive and not adding the noop case if so. 172 | 173 | It'd be nice to solve this by just locally disabling the redundant case 174 | warning with [[@warning "-11"]], but this would have to go on the entire 175 | match (in which case it leaks the users' subexpressions). Unfortunately, 176 | OCaml doesn't support [[@warning "-11"]] on individual patterns. *) 177 | let extensible_cases_are_exhaustive : cases -> bool = 178 | let pattern_matches_anything p = 179 | match p.ppat_desc with Ppat_any | Ppat_var _ -> true | _ -> false 180 | in 181 | List.exists (fun case -> 182 | Option.is_none case.pc_guard && pattern_matches_anything case.pc_lhs) 183 | 184 | (* Given a list of effect handlers, build a corresponding [effc] continuation to 185 | pass to [Deep.{try,match}_with]. *) 186 | let effc ~loc (cases : cases) : expression = 187 | assert (cases <> []); 188 | let noop_case = 189 | match extensible_cases_are_exhaustive cases with 190 | | true -> [] 191 | | false -> [ case ~lhs:[%pat? _] ~guard:None ~rhs:[%expr None] ] 192 | in 193 | (* NOTE: the name [continue_input] is leaked to the user (accessible from 194 | their code, and appears in error message). *) 195 | [%expr 196 | let effc : 197 | type continue_input. 198 | continue_input Stdlib.Effect.t -> 199 | ((continue_input, _) Stdlib.Effect.Deep.continuation -> _) option = 200 | [%e pexp_function ~loc (cases @ noop_case)] 201 | in 202 | effc] 203 | 204 | (* Given a list of exception handlers, build a corresponding [exnc] continuation 205 | to pass to [Deep.{try,match}_with]. *) 206 | let exnc ~loc (cases : cases) : expression = 207 | match cases with 208 | | [] -> [%expr Ppx_effects_runtime.raise] 209 | | _ :: _ -> 210 | let noop_case = 211 | match extensible_cases_are_exhaustive cases with 212 | | true -> [] 213 | | false -> 214 | [ 215 | case 216 | ~lhs:[%pat? e] 217 | ~guard:None 218 | ~rhs:[%expr Ppx_effects_runtime.raise e]; 219 | ] 220 | in 221 | pexp_function ~loc (cases @ noop_case) 222 | 223 | (* Captures top-level [%effect? _] in [try] / [match] expressions and converts 224 | them to [Deep.{try,match}_with]. 225 | 226 | Also handles [exception%effect ...] in structures – see below. *) 227 | let impl : structure -> structure = 228 | (object (this) 229 | inherit Ast_traverse.map as super 230 | 231 | method! expression expr = 232 | let loc = expr.pexp_loc in 233 | match expr with 234 | (* Handles: [ match _ with [%effect? E _, k] -> ... ] *) 235 | | { pexp_desc = Pexp_match (scrutinee, cases); _ } 236 | when Cases.contain_effect_handler cases -> 237 | let scrutinee = 238 | Scrutinee.of_expression (this#expression scrutinee) 239 | in 240 | let cases = Cases.partition ~map_subnodes:this cases in 241 | let retc = 242 | match cases.ret with 243 | | [] -> 244 | raise_errorf ~loc 245 | "none of the patterns in this %a expression match values." 246 | pp_quoted "match" 247 | | _ :: _ -> pexp_function ~loc cases.ret 248 | and exnc = exnc ~loc cases.exn 249 | and effc = effc ~loc cases.eff in 250 | [%expr 251 | Ppx_effects_runtime.match_with [%e scrutinee.function_] 252 | [%e scrutinee.argument] 253 | { 254 | Ppx_effects_runtime.retc = [%e retc]; 255 | exnc = [%e exnc]; 256 | effc = [%e effc]; 257 | }] 258 | (* Handles: [ try _ with [%effect? E _, k] -> ... ] *) 259 | | { pexp_desc = Pexp_try (scrutinee, cases); _ } 260 | when Cases.contain_effect_handler cases -> 261 | let scrutinee = 262 | Scrutinee.of_expression (this#expression scrutinee) 263 | in 264 | let cases = Cases.partition ~map_subnodes:this cases in 265 | let effc = effc ~loc cases.eff in 266 | [%expr 267 | Ppx_effects_runtime.try_with [%e scrutinee.function_] 268 | [%e scrutinee.argument] 269 | { Ppx_effects_runtime.effc = [%e effc] }] 270 | | e -> super#expression e 271 | 272 | method! extension = 273 | function 274 | | { txt = "effect"; loc }, _ -> 275 | raise_errorf ~loc 276 | "dangling [%%effect ...] extension node. This node may be used as:\n\ 277 | \ - the top level of %a or %a patterns as %a\n\ 278 | \ - on an exception definition as %a." pp_quoted "match" pp_quoted 279 | "try" pp_quoted "[%effect? ...]" pp_quoted "exception%effect ..." 280 | | e -> super#extension e 281 | end) 282 | #structure 283 | 284 | let effect_decl_of_exn_decl ~loc (exn : type_exception) : type_extension = 285 | let name = exn.ptyexn_constructor.pext_name in 286 | let eff_type = Located.lident ~loc "Stdlib.Effect.t" in 287 | let constrs, v, args = 288 | match exn.ptyexn_constructor.pext_kind with 289 | | Pext_decl (constrs, v, body) -> 290 | let body = 291 | Option.map (fun typ -> ptyp_constr ~loc eff_type [ typ ]) body 292 | in 293 | (constrs, body, v) 294 | | Pext_rebind _ -> 295 | raise_errorf ~loc "cannot process effect defined as an alias of %a." 296 | pp_quoted name.txt 297 | in 298 | let params = [ (ptyp_any ~loc, (NoVariance, NoInjectivity)) ] in 299 | type_extension ~loc ~path:eff_type ~params 300 | ~constructors: 301 | [ extension_constructor ~loc ~name ~kind:(Pext_decl (constrs, args, v)) ] 302 | ~private_:Public 303 | 304 | let str_effect_decl = 305 | Extension.declare "effect" Structure_item 306 | Ast_pattern.(pstr (pstr_exception __ ^:: nil)) 307 | (fun ~loc ~path:_ exn -> 308 | pstr_typext ~loc (effect_decl_of_exn_decl ~loc exn)) 309 | 310 | let sig_effect_decl = 311 | Extension.declare "effect" Signature_item 312 | Ast_pattern.(psig (psig_exception __ ^:: nil)) 313 | (fun ~loc ~path:_ exn -> 314 | psig_typext ~loc (effect_decl_of_exn_decl ~loc exn)) 315 | 316 | let () = 317 | Reserved_namespaces.reserve namespace; 318 | Driver.register_transformation 319 | ~extensions:[ str_effect_decl; sig_effect_decl ] 320 | ~impl namespace 321 | 322 | (*———————————————————————————————————————————————————————————————————————————— 323 | Copyright (c) 2021 Craig Ferguson 324 | 325 | Permission to use, copy, modify, and/or distribute this software for any 326 | purpose with or without fee is hereby granted, provided that the above 327 | copyright notice and this permission notice appear in all copies. 328 | 329 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 330 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 331 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 332 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 333 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 334 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 335 | DEALINGS IN THE SOFTWARE. 336 | ————————————————————————————————————————————————————————————————————————————*) 337 | --------------------------------------------------------------------------------