├── .github ├── dependabot.yaml └── workflows │ └── ocaml.yml ├── .gitignore ├── CHANGELOG.markdown ├── CONTRIBUTING.markdown ├── CONTRIBUTORS.markdown ├── LICENSE ├── README.markdown ├── algaeff.opam ├── dune-project ├── src ├── Algaeff.ml ├── Algaeff.mli ├── Fun.ml ├── Fun.mli ├── Mutex.ml ├── Mutex.mli ├── Reader.ml ├── Reader.mli ├── Sequencer.ml ├── Sequencer.mli ├── Sigs.ml ├── State.ml ├── State.mli ├── UniqueID.ml ├── UniqueID.mli └── dune └── test ├── Example.expected ├── Example.ml ├── Example.mli ├── TestMutex.ml ├── TestMutex.mli ├── TestReader.ml ├── TestReader.mli ├── TestSequencer.ml ├── TestSequencer.mli ├── TestState.ml ├── TestState.mli ├── TestUniqueID.ml ├── TestUniqueID.mli ├── Unmonad.ml ├── Unmonad.mli └── dune /.github/dependabot.yaml: -------------------------------------------------------------------------------- 1 | version: 2 2 | updates: 3 | - package-ecosystem: "github-actions" 4 | directory: "/" 5 | schedule: 6 | interval: "daily" 7 | -------------------------------------------------------------------------------- /.github/workflows/ocaml.yml: -------------------------------------------------------------------------------- 1 | name: Build, test, and doc update 2 | on: 3 | push: 4 | branches: 5 | - main 6 | pull_request: 7 | jobs: 8 | run: 9 | strategy: 10 | matrix: 11 | include: 12 | - ocaml-compiler: "ocaml-base-compiler.5.0.0" 13 | - ocaml-compiler: "ocaml-base-compiler.5.1.1" 14 | with-doc: true 15 | runs-on: ubuntu-latest 16 | steps: 17 | - uses: actions/checkout@v4 18 | - uses: RedPRL/actions-ocaml@v2 19 | with: 20 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 21 | with-doc: ${{ matrix.with-doc }} 22 | publish-doc-if-built: ${{ github.ref == 'refs/heads/main' }} 23 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | node_modules 2 | 3 | # -*- mode: gitignore; -*- 4 | *.install 5 | *~ 6 | \#*\# 7 | /.emacs.desktop 8 | /.emacs.desktop.lock 9 | *.elc 10 | auto-save-list 11 | tramp 12 | .\#* 13 | 14 | # Org-mode 15 | .org-id-locations 16 | *_archive 17 | 18 | # flymake-mode 19 | *_flymake.* 20 | 21 | # eshell files 22 | /eshell/history 23 | /eshell/lastdir 24 | 25 | # elpa packages 26 | /elpa/ 27 | 28 | # reftex files 29 | *.rel 30 | 31 | # AUCTeX auto folder 32 | auto/ 33 | 34 | # cask packages 35 | .cask/ 36 | dist/ 37 | 38 | # Flycheck 39 | flycheck_*.el 40 | 41 | # server auth directory 42 | /server/ 43 | 44 | # projectiles files 45 | .projectile 46 | 47 | # directory configuration 48 | .dir-locals.el 49 | 50 | 51 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/Linux.gitignore 52 | 53 | *~ 54 | 55 | # temporary files which can be created if a process still has a handle open of a deleted file 56 | .fuse_hidden* 57 | 58 | # KDE directory preferences 59 | .directory 60 | 61 | # Linux trash folder which might appear on any partition or disk 62 | .Trash-* 63 | 64 | # .nfs files are created when an open file is removed but is still being accessed 65 | .nfs* 66 | 67 | 68 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/macOS.gitignore 69 | 70 | # General 71 | .DS_Store 72 | .AppleDouble 73 | .LSOverride 74 | 75 | # Icon must end with two \r 76 | Icon 77 | 78 | 79 | # Thumbnails 80 | ._* 81 | 82 | # Files that might appear in the root of a volume 83 | .DocumentRevisions-V100 84 | .fseventsd 85 | .Spotlight-V100 86 | .TemporaryItems 87 | .Trashes 88 | .VolumeIcon.icns 89 | .com.apple.timemachine.donotpresent 90 | 91 | # Directories potentially created on remote AFP share 92 | .AppleDB 93 | .AppleDesktop 94 | Network Trash Folder 95 | Temporary Items 96 | .apdisk 97 | 98 | 99 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/OCaml.gitignore 100 | 101 | *.annot 102 | *.cmo 103 | *.cma 104 | *.cmi 105 | *.a 106 | *.o 107 | *.cmx 108 | *.cmxs 109 | *.cmxa 110 | 111 | # ocamlbuild working directory 112 | _build/ 113 | 114 | # ocamlbuild targets 115 | *.byte 116 | *.native 117 | 118 | # oasis generated files 119 | setup.data 120 | setup.log 121 | 122 | # Merlin configuring file for Vim and Emacs 123 | .merlin 124 | -------------------------------------------------------------------------------- /CHANGELOG.markdown: -------------------------------------------------------------------------------- 1 | # [2.0.0](https://github.com/RedPRL/algaeff/compare/1.1.0...2.0.0) (2023-10-31) 2 | 3 | This major release has two breaking changes: 4 | 5 | 1. `Algaeff.{Reader,Sequencer,State,UniqueID}` are now taking a module with a type `t`. Previously, the type is named `elt`, `env`, or `state` depending on the component. Now, it is always named `t`. The benefit is that one can write succinct code for built-in types: 6 | ```ocaml 7 | module R = Algaeff.Reader.Make (Bool) 8 | module Sq = Algaeff.Sequencer.Make (Int) 9 | module St = Algaeff.State.Make (Int) 10 | module St = Algaeff.UniqueID.Make (String) 11 | ``` 12 | To upgrade from the older version of this library, please change the type name (`env`, `elt`, or `state`) in 13 | ```ocaml 14 | module R = Algaeff.Reader.Make (struct type env = ... end) 15 | module Sq = Algaeff.Sequencer.Make (struct type elt = ... end) 16 | module St = Algaeff.State.Make (struct type state = ... end) 17 | module U = Algaeff.UniqueID.Make (struct type elt = ... end) 18 | ``` 19 | to `t` as follows: 20 | ```ocaml 21 | module R = Algaeff.Reader.Make (struct type t = ... end) 22 | module Sq = Algaeff.Sequencer.Make (struct type t = ... end) 23 | module St = Algaeff.State.Make (struct type t = ... end) 24 | module U = Algaeff.UniqueID.Make (struct type t = ... end) 25 | ``` 26 | 2. `Algaeff.Unmonad` is removed. 27 | 28 | # [1.1.0](https://github.com/RedPRL/algaeff/compare/1.0.0...1.1.0) (2023-10-01) 29 | 30 | ### Features 31 | 32 | - `{Mutex,Reader,Sequencer,State,UniqueID}.register_printer` to add custom printers for unhandled effects (available in all components except `Unmonad`) ([#19](https://github.com/RedPRL/algaeff/issues/19)) ([2a13145](https://github.com/RedPRL/algaeff/commit/2a13145bca6ef107cb7d80f61c8e34b297d4c723)) ([#22](https://github.com/RedPRL/algaeff/issues/22)) ([9bb4788](https://github.com/RedPRL/algaeff/commit/9bb4788bcab99b3dd40432da87a6de1810c6ad42)) 33 | -------------------------------------------------------------------------------- /CONTRIBUTING.markdown: -------------------------------------------------------------------------------- 1 | # Copyright Assignment 2 | 3 | Thank you for your contribution. Here is some important legal stuff. 4 | 5 | By submitting a pull request for this project, unless explicitly stated otherwise, you agree to assign your copyright of the contribution to **The RedPRL Development Team** when it is accepted (merged with or without minor changes). You assert that you have full power to assign the copyright, and that any copyright owned by or shared with a third party has been clearly marked with appropriate copyright notices. If you are employed, please check with your employer about the ownership of your contribution. 6 | 7 | This would allow us to, for example, change the license of the codebase to Apache 2.0 or transfer the ownership of the project to someone else *without your further consent*. We demand this assignment so that we do not have to ask *everyone* who has ever contributed for these activities. This requires trust, and if you feel uncomfortable about this assignment, please make an explicit note. 8 | -------------------------------------------------------------------------------- /CONTRIBUTORS.markdown: -------------------------------------------------------------------------------- 1 | # CONTRIBUTORS 2 | 3 | - Favonia 4 | - Matthew McQuaid 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "[]" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright [yyyy] [name of copyright owner] 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # 🦠 Reusable Effects-Based Components 2 | 3 | This library aims to collect reusable, general effects-based components we have seen when constructing our proof assistants using OCaml 5. All components here have appeared in various tutorials on algebraic effects; `algaeff` wraps these well-known components into an OPAM package. 4 | 5 | ## API Stability 6 | 7 | We use [semantic versioning.](https://semver.org/) Breaking changes will bump the major version number. 8 | 9 | ## Components 10 | 11 | - [Algaeff.State](https://redprl.org/algaeff/algaeff/Algaeff/State): mutable states 12 | - [Algaeff.Reader](https://redprl.org/algaeff/algaeff/Algaeff/Reader): read-only environments 13 | - [Algaeff.Sequencer](https://redprl.org/algaeff/algaeff/Algaeff/Sequencer): making a `Seq.t` 14 | - [Algaeff.Mutex](https://redprl.org/algaeff/algaeff/Algaeff/Mutex): simple locking to prevent re-entrance 15 | - [Algaeff.UniqueID](https://redprl.org/algaeff/algaeff/Algaeff/UniqueID): generating unique IDs 16 | 17 | Effects-based concurrency (cooperative lightweight threading) was already tackled by other libraries such as [Eio](https://github.com/ocaml-multicore/eio) and [Affect](https://erratique.ch/software/affect). This library focuses on the rest. 18 | 19 | There are a few other useful functions: 20 | 21 | - [Algaeff.Fun.Deep.finally](https://redprl.org/algaeff/algaeff/Algaeff/Fun/Deep/index.html#val-finally): call `continue` or `discontinue` accordingly. 22 | - [Algaeff.Fun.Shallow.finally_with](https://redprl.org/algaeff/algaeff/Algaeff/Fun/Shallow/index.html#val-finally_with): same as above, but for shallow effect handlers. 23 | 24 | ## How to Use It 25 | 26 | ### OCaml >= 5.0.0 27 | 28 | You need OCaml 5. 29 | 30 | ### Example Code 31 | 32 | ```ocaml 33 | module S = Algaeff.State.Make (Int) 34 | 35 | let forty_two = S.run ~init:100 @@ fun () -> 36 | print_int (S.get ()); (* this will print out 100 *) 37 | S.set 42; 38 | S.get () 39 | ``` 40 | 41 | ### Documentation 42 | 43 | [Here is the API documentation.](https://redprl.org/algaeff/algaeff/Algaeff) 44 | -------------------------------------------------------------------------------- /algaeff.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "algaeff" 3 | synopsis: "Reusable Effects-Based Components" 4 | description: """ 5 | This OCaml library collects reusable effects-based components we have identified while developing our proof assistants based on algebraic effects. 6 | """ 7 | maintainer: "favonia " 8 | authors: "The RedPRL Development Team" 9 | license: "Apache-2.0" 10 | homepage: "https://github.com/RedPRL/algaeff" 11 | bug-reports: "https://github.com/RedPRL/algaeff/issues" 12 | dev-repo: "git+https://github.com/RedPRL/algaeff.git" 13 | depends: [ 14 | "dune" {>= "2.0"} 15 | "ocaml" {>= "5.0"} 16 | "alcotest" {>= "1.5" & with-test} 17 | "qcheck-core" {>= "0.18" & with-test} 18 | "odoc" {with-doc} 19 | ] 20 | build: [ 21 | ["dune" "build" "-p" name "-j" jobs] 22 | ["dune" "build" "-p" name "-j" jobs "@runtest"] {with-test} 23 | ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} 24 | ] 25 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | (formatting disabled) 3 | -------------------------------------------------------------------------------- /src/Algaeff.ml: -------------------------------------------------------------------------------- 1 | module State = State 2 | module Reader = Reader 3 | module Sequencer = Sequencer 4 | module Mutex = Mutex 5 | module UniqueID = UniqueID 6 | module Sigs = Sigs 7 | module Fun = Fun 8 | -------------------------------------------------------------------------------- /src/Algaeff.mli: -------------------------------------------------------------------------------- 1 | (** Reusable effects-based components. *) 2 | 3 | (** {1 Reusable components} *) 4 | 5 | module State = State 6 | 7 | module Reader = Reader 8 | 9 | module Sequencer = Sequencer 10 | 11 | module Mutex = Mutex 12 | 13 | module UniqueID = UniqueID 14 | 15 | (** {1 Auxiliary modules} *) 16 | 17 | module Sigs = Sigs 18 | 19 | module Fun = Fun 20 | -------------------------------------------------------------------------------- /src/Fun.ml: -------------------------------------------------------------------------------- 1 | module Deep = 2 | struct 3 | let finally k f = 4 | match f () with 5 | | x -> Effect.Deep.continue k x 6 | | exception e -> Effect.Deep.discontinue k e 7 | end 8 | 9 | module Shallow = 10 | struct 11 | let finally_with k f h = 12 | match f () with 13 | | x -> Effect.Shallow.continue_with k x h 14 | | exception e -> Effect.Shallow.discontinue_with k e h 15 | end 16 | -------------------------------------------------------------------------------- /src/Fun.mli: -------------------------------------------------------------------------------- 1 | (** Useful helper functions around effects. *) 2 | 3 | module Deep : 4 | sig 5 | (** Useful helper functions for deep handlers. *) 6 | 7 | val finally : ('a, 'b) Effect.Deep.continuation -> (unit -> 'a) -> 'b 8 | (** [finally f] runs the thunk [f] and calls [continue] if a value is returned and [discontinue] if an exception is raised. 9 | Here is an example that calls {!val:List.nth} and then either returns the found element with [continue] 10 | or raises the exception {!exception:Not_found} with [discontinue]. 11 | {[ 12 | Algaeff.Fun.Deep.finally k @@ fun () -> List.nth elements n 13 | ]} 14 | *) 15 | end 16 | 17 | module Shallow : 18 | sig 19 | (** Useful helper functions for shallow handlers. *) 20 | 21 | val finally_with : ('a, 'b) Effect.Shallow.continuation -> (unit -> 'a) -> ('b, 'c) Effect.Shallow.handler -> 'c 22 | (** See {!val:Deep.finally}. *) 23 | end 24 | -------------------------------------------------------------------------------- /src/Mutex.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | exception Locked 4 | 5 | val exclusively : (unit -> 'a) -> 'a 6 | val run : (unit -> 'a) -> 'a 7 | 8 | val register_printer : ([`Exclusively] -> string option) -> unit 9 | end 10 | 11 | module Make () = 12 | struct 13 | exception Locked 14 | 15 | let () = Printexc.register_printer @@ 16 | function 17 | | Locked -> Some "Mutex already locked" 18 | | _ -> None 19 | 20 | module S = State.Make (Bool) 21 | 22 | let exclusively f = 23 | if S.get() then 24 | raise Locked 25 | else begin 26 | S.set true; 27 | (* Favonia: I learn from the developers of eio that Fun.protect is not good at 28 | preserving the backtraces. See https://github.com/ocaml-multicore/eio/pull/209. *) 29 | match f () with 30 | | ans -> S.set false; ans 31 | | exception e -> S.set false; raise e 32 | end 33 | 34 | let run f = S.run ~init:false f 35 | 36 | let register_printer f = S.register_printer @@ fun _ -> f `Exclusively 37 | 38 | let () = register_printer @@ fun _ -> Some "Unhandled algaeff effect; use Algaeff.Mutex.run" 39 | end 40 | -------------------------------------------------------------------------------- /src/Mutex.mli: -------------------------------------------------------------------------------- 1 | (** Effects for making concurrent execution immediately fail. *) 2 | 3 | (** 4 | {[ 5 | module M = Algaeff.Mutex.Make () 6 | 7 | let () = M.run @@ fun () -> 8 | let ten = M.exclusively @@ fun () -> 10 in 9 | let nine = M.exclusively @@ fun () -> 9 in 10 | (* this will print out 19 *) 11 | print_int (ten + nine) 12 | 13 | let _ = M.run @@ fun () -> 14 | M.exclusively @@ fun () -> 15 | (* this raises M.Locked *) 16 | M.exclusively @@ fun () -> 17 | 100 18 | ]} 19 | *) 20 | 21 | (** Note that the exception {!exception:S.Locked} would be immediately raised 22 | for any attempt to lock an already locked mutex. 23 | The typical application of this component is to prevent erroneous concurrent API access, 24 | not to provide synchronization. Therefore, no waiting would happen. 25 | 26 | It is impossible to implement meaningful synchronization 27 | unless this module also handles lightweight threading. 28 | For applications that need synchronization between lightweight threads 29 | (so that one thread would wait for another thread to unlock the mutex), 30 | check out other libraries such as the {{: https://github.com/ocaml-multicore/eio}Eio} 31 | and {{: https://erratique.ch/software/affect}Affect}. *) 32 | 33 | module type S = 34 | sig 35 | (** The signature of mutex effects. *) 36 | 37 | exception Locked 38 | (** The exception raised by {!val:exclusively} if the mutex was locked. *) 39 | 40 | val exclusively : (unit -> 'a) -> 'a 41 | (** [exclusively f] locks the mutex, run the thunk [f], and then unlock the mutex. 42 | If the mutex was already locked, [exclusively f] immediately raises {!exception:Locked} 43 | without waiting. Note that calling [exclusively] inside [f] is an instance of 44 | attempting to lock an already locked mutex. 45 | 46 | @raises Locked The mutex was already locked. *) 47 | 48 | val run : (unit -> 'a) -> 'a 49 | (** [run f] executes the thunk [f] which may perform mutex effects. 50 | Each call of [run] creates a fresh mutex; in particular, calling [run] inside 51 | the thunk [f] will start a new scope that does not interfere with the outer scope. *) 52 | 53 | val register_printer : ([`Exclusively] -> string option) -> unit 54 | (** [register_printer p] registers a printer [p] via {!val:Printexc.register_printer} to convert unhandled internal effects into strings for the OCaml runtime system to display. Ideally, all internal effects should have been handled by {!val:run} and there is no need to use this function, but when it is not the case, this function can be helpful for debugging. The functor {!module:Mutex.Make} always registers a simple printer to suggest using {!val:run}, but you can register new ones to override it. The return type of the printer [p] should return [Some s] where [s] is the resulting string, or [None] if it chooses not to convert a particular effect. The registered printers are tried in reverse order until one of them returns [Some s] for some [s]; that is, the last registered printer is tried first. Note that this function is a wrapper of {!val:Printexc.register_printer} and all the registered printers (via this function or {!val:Printexc.register_printer}) are put into the same list. 55 | 56 | The input type of the printer [p] is a variant representing internal effects used in this module. It corresponds to all the effects trigger by {!val:exclusively}. 57 | 58 | @since 1.1.0 59 | *) 60 | end 61 | 62 | module Make () : S 63 | (** The implementation of mutex effects. [Make] is generative so that one can use multiple 64 | mutexes at the same time. *) 65 | -------------------------------------------------------------------------------- /src/Reader.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type env 4 | val read : unit -> env 5 | val scope : (env -> env) -> (unit -> 'a) -> 'a 6 | val run : env:env -> (unit -> 'a) -> 'a 7 | val register_printer : ([`Read] -> string option) -> unit 8 | end 9 | 10 | module Make (Env : Sigs.Type) = 11 | struct 12 | type _ Effect.t += Read : Env.t Effect.t 13 | 14 | let read () = Effect.perform Read 15 | 16 | let run ~(env:Env.t) f = 17 | let open Effect.Deep in 18 | try_with f () 19 | { effc = fun (type a) (eff : a Effect.t) -> 20 | match eff with 21 | | Read -> Option.some @@ fun (k : (a, _) continuation) -> 22 | continue k env 23 | | _ -> None } 24 | 25 | let scope f c = run ~env:(f @@ read ()) c 26 | 27 | let register_printer f = Printexc.register_printer @@ function 28 | | Effect.Unhandled Read -> f `Read 29 | | _ -> None 30 | 31 | let () = register_printer @@ fun _ -> Some "Unhandled algaeff effect; use Algaeff.Reader.run" 32 | end 33 | -------------------------------------------------------------------------------- /src/Reader.mli: -------------------------------------------------------------------------------- 1 | (** Effects for reading immutable environments. *) 2 | 3 | (** 4 | {[ 5 | module R = Algaeff.Reader.Make (Int) 6 | 7 | let () = R.run ~env:42 @@ fun () -> 8 | (* this will print out 42 *) 9 | print_int (R.read ()); 10 | 11 | (* this will print out 43 *) 12 | R.scope (fun i -> i + 1) (fun () -> print_int (R.read ())); 13 | 14 | (* this will print out 42 again *) 15 | print_int (R.read ()) 16 | ]} 17 | *) 18 | 19 | module type S = 20 | sig 21 | (** Signatures of read effects. *) 22 | 23 | type env 24 | (** The type of environments. *) 25 | 26 | val read : unit -> env 27 | (** Read the environment. *) 28 | 29 | val scope : (env -> env) -> (unit -> 'a) -> 'a 30 | (** [scope f t] runs the thunk [t] under the new environment that is the result of applying [f] to the current environment. *) 31 | 32 | val run : env:env -> (unit -> 'a) -> 'a 33 | (** [run ~env t] runs the thunk [t] which may perform reading effects on the value [env]. *) 34 | 35 | val register_printer : ([`Read] -> string option) -> unit 36 | (** [register_printer p] registers a printer [p] via {!val:Printexc.register_printer} to convert the unhandled internal effect into a string for the OCaml runtime system to display. Ideally, the internal effect should have been handled by {!val:run} and there is no need to use this function, but when it is not the case, this function can be helpful for debugging. The functor {!module:Reader.Make} always registers a simple printer to suggest using {!val:run}, but you can register new ones to override it. The return type of the printer [p] should return [Some s] where [s] is the resulting string, or [None] if it chooses not to convert a particular effect. The registered printers are tried in reverse order until one of them returns [Some s] for some [s]; that is, the last registered printer is tried first. Note that this function is a wrapper of {!val:Printexc.register_printer} and all the registered printers (via this function or {!val:Printexc.register_printer}) are put into the same list. 37 | 38 | The input type of the printer [p] is a variant representation of the only internal effect used in this module. It corresponds to the effect trigger by {!val:read}. 39 | 40 | @since 1.1.0 41 | *) 42 | end 43 | 44 | module Make (Env : Sigs.Type) : S with type env := Env.t 45 | (** The implementation of read effects. *) 46 | -------------------------------------------------------------------------------- /src/Sequencer.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type elt 4 | val yield : elt -> unit 5 | val run : (unit -> unit) -> elt Seq.t 6 | val register_printer : ([`Yield of elt] -> string option) -> unit 7 | end 8 | 9 | module Make (Elt : Sigs.Type) = 10 | struct 11 | type _ Effect.t += Yield : Elt.t -> unit Effect.t 12 | 13 | let yield x = Effect.perform (Yield x) 14 | 15 | let run f () = 16 | let open Effect.Deep in 17 | try_with (fun () -> f (); Seq.Nil) () 18 | { effc = fun (type a) (eff : a Effect.t) -> 19 | match eff with 20 | | Yield x -> Option.some @@ fun (k : (a, _) continuation) -> 21 | Seq.Cons (x, continue k) 22 | | _ -> None } 23 | 24 | let register_printer f = Printexc.register_printer @@ function 25 | | Effect.Unhandled (Yield elt) -> f (`Yield elt) 26 | | _ -> None 27 | 28 | let () = register_printer @@ fun _ -> Some "Unhandled algaeff effect; use Algaeff.Sequencer.run" 29 | end 30 | -------------------------------------------------------------------------------- /src/Sequencer.mli: -------------------------------------------------------------------------------- 1 | (** Effects for constructing a [Seq.t]. 2 | @since 0.2 *) 3 | 4 | (** 5 | {[ 6 | module S = Algaeff.Sequencer.Make (Int) 7 | 8 | (* The sequence corresponding to [[1; 2; 3]]. *) 9 | let seq : int Seq.t = S.run @@ fun () -> S.yield 1; S.yield 2; S.yield 3 10 | 11 | (* An implementation of [List.to_seq]. *) 12 | let to_seq l : int Seq.t = S.run @@ fun () -> List.iter S.yield l 13 | ]} 14 | *) 15 | 16 | (** The sequencers are generators for [Seq.t]. *) 17 | 18 | module type S = 19 | sig 20 | (** Signatures of sequencing effects. *) 21 | 22 | type elt 23 | (** The type of elements. *) 24 | 25 | val yield : elt -> unit 26 | (** Yield the element. *) 27 | 28 | val run : (unit -> unit) -> elt Seq.t 29 | (** [run t] runs the thunk [t] which may perform sequencing effects. *) 30 | 31 | val register_printer : ([`Yield of elt] -> string option) -> unit 32 | (** [register_printer p] registers a printer [p] via {!val:Printexc.register_printer} to convert unhandled internal effects into strings for the OCaml runtime system to display. Ideally, all internal effects should have been handled by {!val:run} and there is no need to use this function, but when it is not the case, this function can be helpful for debugging. The functor {!module:Sequencer.Make} always registers a simple printer to suggest using {!val:run}, but you can register new ones to override it. The return type of the printer [p] should return [Some s] where [s] is the resulting string, or [None] if it chooses not to convert a particular effect. The registered printers are tried in reverse order until one of them returns [Some s] for some [s]; that is, the last registered printer is tried first. Note that this function is a wrapper of {!val:Printexc.register_printer} and all the registered printers (via this function or {!val:Printexc.register_printer}) are put into the same list. 33 | 34 | The input type of the printer [p] is a variant representation of the internal effects used in this module. They correspond to the effects trigger by {!val:yield}. More precisely, [`Yield elt] corresponds to the effect triggered by [yield elt]. 35 | 36 | @since 1.1.0 37 | *) 38 | end 39 | 40 | module Make (Elt : Sigs.Type) : S with type elt := Elt.t 41 | (** The implementation of sequencing effects. *) 42 | -------------------------------------------------------------------------------- /src/Sigs.ml: -------------------------------------------------------------------------------- 1 | (** Signatures shared across different components. *) 2 | 3 | (** This is a type wrapped as a module. *) 4 | module type Type = 5 | sig 6 | (** The wrapped type. *) 7 | type t 8 | end 9 | -------------------------------------------------------------------------------- /src/State.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type state 4 | val get : unit -> state 5 | val set : state -> unit 6 | val modify : (state -> state) -> unit 7 | val run : init:state -> (unit -> 'a) -> 'a 8 | val try_with : ?get:(unit -> state) -> ?set:(state -> unit) -> (unit -> 'a) -> 'a 9 | val register_printer : ([`Get | `Set of state] -> string option) -> unit 10 | end 11 | 12 | module Make (State : Sigs.Type) = 13 | struct 14 | type _ Effect.t += 15 | | Get : State.t Effect.t 16 | | Set : State.t -> unit Effect.t 17 | 18 | let get () = Effect.perform Get 19 | let set st = Effect.perform (Set st) 20 | 21 | let run ~(init:State.t) f = 22 | let open Effect.Deep in 23 | let st = ref init in 24 | try_with f () 25 | { effc = fun (type a) (eff : a Effect.t) -> 26 | match eff with 27 | | Get -> Option.some @@ fun (k : (a, _) continuation) -> 28 | continue k !st 29 | | Set v -> Option.some @@ fun (k : (a, _) continuation) -> 30 | st := v; continue k () 31 | | _ -> None } 32 | 33 | let try_with ?(get=get) ?(set=set) f = 34 | let open Effect.Deep in 35 | try_with f () 36 | { effc = fun (type a) (eff : a Effect.t) -> 37 | match eff with 38 | | Get -> Option.some @@ fun (k : (a, _) continuation) -> 39 | continue k (get ()) 40 | | Set v -> Option.some @@ fun (k : (a, _) continuation) -> 41 | set v; continue k () 42 | | _ -> None } 43 | 44 | let modify f = set @@ f @@ get () 45 | 46 | let register_printer f = Printexc.register_printer @@ function 47 | | Effect.Unhandled Get -> f `Get 48 | | Effect.Unhandled (Set state) -> f (`Set state) 49 | | _ -> None 50 | 51 | let () = register_printer @@ fun _ -> Some "Unhandled algaeff effect; use Algaeff.State.run" 52 | end 53 | -------------------------------------------------------------------------------- /src/State.mli: -------------------------------------------------------------------------------- 1 | (** Effects for changing states. *) 2 | 3 | (** 4 | {[ 5 | module S = Algaeff.State.Make (Int) 6 | 7 | let forty_two = S.run ~init:100 @@ fun () -> 8 | print_int (S.get ()); (* this will print out 100 *) 9 | S.set 42; 10 | S.get () 11 | ]} 12 | *) 13 | 14 | module type S = 15 | sig 16 | (** Signatures of state effects. *) 17 | 18 | type state 19 | (** The type of states. *) 20 | 21 | val get : unit -> state 22 | (** [get ()] reads the current state. *) 23 | 24 | val set : state -> unit 25 | (** [set x] makes [x] the new state. *) 26 | 27 | val modify : (state -> state) -> unit 28 | (** [modify f] applies [f] to the current state and then set the result as the new state. *) 29 | 30 | val run : init:state -> (unit -> 'a) -> 'a 31 | (** [run ~init t] runs the thunk [t] which may perform state effects. The initial state is [init]. *) 32 | 33 | val try_with : ?get:(unit -> state) -> ?set:(state -> unit) -> (unit -> 'a) -> 'a 34 | (** [try_with ~get ~set t] runs the thunk [t] which may perform state effects, handling these effects with [get] and [set] (which may perform effects from some other module). The default handlers re-perform the effects. *) 35 | 36 | val register_printer : ([`Get | `Set of state] -> string option) -> unit 37 | (** [register_printer p] registers a printer [p] via {!val:Printexc.register_printer} to convert unhandled internal effects into strings for the OCaml runtime system to display. Ideally, all internal effects should have been handled by {!val:run} and there is no need to use this function, but when it is not the case, this function can be helpful for debugging. The functor {!module:Make} always registers a simple printer to suggest using {!val:run}, but you can register new ones to override it. The return type of the printer [p] should return [Some s] where [s] is the resulting string, or [None] if it chooses not to convert a particular effect. The registered printers are tried in reverse order until one of them returns [Some s] for some [s]; that is, the last registered printer is tried first. Note that this function is a wrapper of {!val:Printexc.register_printer} and all the registered printers (via this function or {!val:Printexc.register_printer}) are put into the same list. 38 | 39 | The input type of the printer [p] is a variant representation of the internal effects used in this module. They correspond to the effects trigger by {!val:get} and {!val:set}. More precisely, 40 | - [`Get] corresponds to the effect triggered by [get ()]. 41 | - [`Set state] corresponds to the effect triggered by [set state]. 42 | 43 | @since 1.1.0 44 | *) 45 | end 46 | 47 | module Make (State : Sigs.Type) : S with type state := State.t 48 | (** The implementation of state effects. *) 49 | -------------------------------------------------------------------------------- /src/UniqueID.ml: -------------------------------------------------------------------------------- 1 | module type S = 2 | sig 3 | type elt 4 | 5 | module ID : 6 | sig 7 | type t = private int 8 | val equal : t -> t -> bool 9 | val compare : t -> t -> int 10 | val dump : Format.formatter -> t -> unit 11 | val unsafe_of_int : int -> t 12 | end 13 | type id = ID.t 14 | 15 | val register : elt -> id 16 | val retrieve : id -> elt 17 | val export : unit -> elt Seq.t 18 | val run : ?init:elt Seq.t -> (unit -> 'a) -> 'a 19 | val register_printer : ([`Register of elt | `Retrieve of id | `Export] -> string option) -> unit 20 | end 21 | 22 | module Make (Elt : Sigs.Type) = 23 | struct 24 | module ID = 25 | struct 26 | type t = int 27 | let equal = Int.equal 28 | let compare = Int.compare 29 | let dump = Format.pp_print_int 30 | let unsafe_of_int i = i 31 | end 32 | type id = int 33 | 34 | type _ Effect.t += 35 | | Register : Elt.t -> id Effect.t 36 | | Retrieve : id -> Elt.t Effect.t 37 | | Export : Elt.t Seq.t Effect.t 38 | 39 | let register x = Effect.perform (Register x) 40 | let retrieve i = Effect.perform (Retrieve i) 41 | let export () = Effect.perform Export 42 | 43 | module M = Map.Make (Int) 44 | module Eff = State.Make (struct type t = Elt.t M.t end) 45 | 46 | let run ?(init=Seq.empty) f = 47 | let init = M.of_seq @@ Seq.zip (Seq.ints 0) init in 48 | Eff.run ~init @@ fun () -> 49 | let open Effect.Deep in 50 | try_with f () 51 | { effc = fun (type a) (eff : a Effect.t) -> 52 | match eff with 53 | | Register x -> Option.some @@ fun (k : (a, _) continuation) -> 54 | let st = Eff.get () in 55 | let next = M.cardinal st in 56 | Eff.set @@ M.add next x st; 57 | continue k next 58 | | Retrieve i -> Option.some @@ fun (k : (a, _) continuation) -> 59 | continue k @@ M.find i @@ Eff.get () 60 | | Export -> Option.some @@ fun (k : (a, _) continuation) -> 61 | continue k @@ Seq.map snd @@ M.to_seq @@ Eff.get () 62 | | _ -> None } 63 | 64 | let register_printer f = Printexc.register_printer @@ function 65 | | Effect.Unhandled (Register elt) -> f (`Register elt) 66 | | Effect.Unhandled (Retrieve id) -> f (`Retrieve id) 67 | | Effect.Unhandled Export -> f `Export 68 | | _ -> None 69 | 70 | let () = register_printer @@ fun _ -> Some "Unhandled algaeff effect; use Algaeff.UniqueID.run" 71 | end 72 | -------------------------------------------------------------------------------- /src/UniqueID.mli: -------------------------------------------------------------------------------- 1 | (** Effects for generating unique IDs. 2 | @since 0.2 *) 3 | 4 | (** Generate unique IDs for registered items. *) 5 | 6 | module type S = 7 | sig 8 | (** Signatures of the effects. *) 9 | 10 | type elt 11 | (** The type of elements *) 12 | 13 | (** The type of IDs and its friends. *) 14 | module ID : 15 | sig 16 | type t = private int 17 | (** Semi-abstract type of IDs. *) 18 | 19 | val equal : t -> t -> bool 20 | (** Checking whether two IDs are equal. *) 21 | 22 | val compare : t -> t -> int 23 | (** Compare two IDs. *) 24 | 25 | val dump : Format.formatter -> t -> unit 26 | (** Printing the ID. *) 27 | 28 | val unsafe_of_int : int -> t 29 | (** Unsafe conversion from [int]. Should be used only for de-serialization. *) 30 | end 31 | 32 | type id = ID.t 33 | (** The type of unique IDs. The client should not assume a particular indexing scheme. *) 34 | 35 | val register : elt -> id 36 | (** Register a new item and get an ID. Note that registering the same item twice will get two different IDs. *) 37 | 38 | val retrieve : id -> elt 39 | (** Retrieve the item associated with the ID. *) 40 | 41 | val export : unit -> elt Seq.t 42 | (** Export the internal storage for serialization. Once exported, the representation is persistent and can be traversed without the effect handler. *) 43 | 44 | val run : ?init:elt Seq.t -> (unit -> 'a) -> 'a 45 | (** [run t] runs the thunk [t] and handles the effects for generating unique IDs. 46 | 47 | @param init The initial storage, which should be the output of some previous {!val:export}. 48 | *) 49 | 50 | val register_printer : ([`Register of elt | `Retrieve of id | `Export] -> string option) -> unit 51 | (** [register_printer p] registers a printer [p] via {!val:Printexc.register_printer} to convert unhandled internal effects into strings for the OCaml runtime system to display. Ideally, all internal effects should have been handled by {!val:run} and there is no need to use this function, but when it is not the case, this function can be helpful for debugging. The functor {!module:UniqueID.Make} always registers a simple printer to suggest using {!val:run}, but you can register new ones to override it. The return type of the printer [p] should return [Some s] where [s] is the resulting string, or [None] if it chooses not to convert a particular effect. The registered printers are tried in reverse order until one of them returns [Some s] for some [s]; that is, the last registered printer is tried first. Note that this function is a wrapper of {!val:Printexc.register_printer} and all the registered printers (via this function or {!val:Printexc.register_printer}) are put into the same list. 52 | 53 | The input type of the printer [p] is a variant representation of the internal effects used in this module. They correspond to the effects trigger by {!val:register}, {!val:retrieve} and {!val:export}. More precisely, 54 | - [`Register elt] corresponds to the effect triggered by [register elt]. 55 | - [`Retrieve id] corresponds to the effect triggered by [retrieve id]. 56 | - [`Export] corresponds to the effect triggered by [export ()]. 57 | 58 | @since 1.1.0 59 | *) 60 | end 61 | 62 | module Make (Elt : Sigs.Type) : S with type elt := Elt.t 63 | (** The implementation of the effects. *) 64 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name Algaeff) 3 | (public_name algaeff)) 4 | -------------------------------------------------------------------------------- /test/Example.expected: -------------------------------------------------------------------------------- 1 | 100 -------------------------------------------------------------------------------- /test/Example.ml: -------------------------------------------------------------------------------- 1 | module S = Algaeff.State.Make (Int) 2 | 3 | let forty_two = S.run ~init:100 @@ fun () -> 4 | print_int (S.get ()); (* this will print out 100 *) 5 | S.set 42; 6 | S.get () 7 | 8 | let () = assert (forty_two = 42) 9 | -------------------------------------------------------------------------------- /test/Example.mli: -------------------------------------------------------------------------------- 1 | (* This file is intentionally blank to detect unused declarations. *) 2 | -------------------------------------------------------------------------------- /test/TestMutex.ml: -------------------------------------------------------------------------------- 1 | module AT = Alcotest 2 | module M1 = Algaeff.Mutex.Make () 3 | module M2 = Algaeff.Mutex.Make () 4 | 5 | type cmd = Ret | M1E of prog | M2E of prog | M1R of prog | M2R of prog 6 | and prog = cmd list 7 | 8 | let realize (p, r) () = 9 | let rec go = 10 | function 11 | | Ret -> () 12 | | M1E p -> M1.exclusively @@ fun () -> go_prog p 13 | | M2E p -> M2.exclusively @@ fun () -> go_prog p 14 | | M1R p -> M1.run @@ fun () -> go_prog p 15 | | M2R p -> M2.run @@ fun () -> go_prog p 16 | and go_prog p = List.iter go p 17 | in 18 | match r with 19 | | Ok () -> 20 | Alcotest.(check unit) "no exception" () 21 | (go_prog p) 22 | | Error exn -> 23 | Alcotest.check_raises "exception" exn 24 | (fun () -> go_prog p) 25 | 26 | let tests = [ 27 | [Ret], Ok (); 28 | [M1R [M1E [Ret]; M1E [Ret]]], Ok (); 29 | [M1R [M1E [M1E [Ret]]]], Error M1.Locked; 30 | [M1R [M2R [M1E [M2E [Ret]]]]], Ok (); 31 | [M1R [M2R [M2E [M1E [Ret]]]]], Ok (); 32 | [M1R [M2R [M1E [Ret]; M2E [Ret]]]], Ok (); 33 | ] 34 | 35 | let () = 36 | let open Alcotest in 37 | run "Mutex" [ 38 | "exclusively", List.map (fun t -> test_case "ok" `Quick @@ realize t) tests 39 | ] 40 | -------------------------------------------------------------------------------- /test/TestMutex.mli: -------------------------------------------------------------------------------- 1 | (* This file is intentionally blank to detect unused declarations. *) 2 | -------------------------------------------------------------------------------- /test/TestReader.ml: -------------------------------------------------------------------------------- 1 | module Q = QCheck2 2 | 3 | module ReaderEff = Algaeff.Reader.Make (Int) 4 | 5 | module ReaderMonad = 6 | struct 7 | type 'a t = int -> 'a 8 | let ret x _ = x 9 | let bind m f e = f (m e) e 10 | let read e = e 11 | let scope f m e = m (f e) 12 | end 13 | 14 | module ReaderUnmonad = 15 | struct 16 | module U = Unmonad.Make (ReaderMonad) 17 | let read () = U.perform ReaderMonad.read 18 | let scope f m = U.perform @@ ReaderMonad.scope f @@ U.run m 19 | let run ~env f = U.run f env 20 | let register_printer _ = () 21 | end 22 | 23 | type cmd = ReadAndPrint | Scope of (int -> int) * prog 24 | and prog = cmd list 25 | 26 | let gen_cmd = 27 | let open Q.Gen in 28 | sized @@ fix @@ fun g -> 29 | function 30 | | 0 -> pure ReadAndPrint 31 | | s -> 32 | frequency 33 | [ 10, pure ReadAndPrint; (* 10 enables fast testing; 20 would be even faster *) 34 | 1, map2 (fun (Q.Fun (_, f)) p -> Scope (f, p)) 35 | (Q.fun1 Q.Observable.int int) 36 | (small_list (g (s/2))) (* s/2 enables fast testing; s-1 is too slow *) 37 | ] 38 | 39 | let gen_prog = Q.Gen.list gen_cmd 40 | 41 | module ReaderTester (S : Algaeff.Reader.S with type env := int) = 42 | struct 43 | let trace ~env prog = 44 | let rec go = 45 | function 46 | | ReadAndPrint -> [S.read ()] 47 | | Scope (f, p) -> S.scope f @@ fun () -> go_prog p 48 | and go_prog p = List.concat_map go p 49 | in 50 | S.run ~env @@ fun () -> go_prog prog 51 | end 52 | 53 | module ReaderEffTester = ReaderTester (ReaderEff) 54 | module ReaderUnmonadTester = ReaderTester (ReaderUnmonad) 55 | 56 | let test_prog = 57 | Q.Test.make ~name:"Reader" (Q.Gen.pair Q.Gen.int gen_prog) 58 | (fun (env, prog) -> 59 | List.equal Int.equal 60 | (ReaderEffTester.trace ~env prog) 61 | (ReaderUnmonadTester.trace ~env prog)) 62 | 63 | let () = 64 | exit @@ 65 | QCheck_base_runner.run_tests ~colors:true ~verbose:true ~long:true 66 | [ test_prog ] 67 | -------------------------------------------------------------------------------- /test/TestReader.mli: -------------------------------------------------------------------------------- 1 | (* This file is intentionally blank to detect unused declarations. *) 2 | -------------------------------------------------------------------------------- /test/TestSequencer.ml: -------------------------------------------------------------------------------- 1 | module Q = QCheck2 2 | 3 | module SequencerEff = Algaeff.Sequencer.Make (Int) 4 | 5 | type 'a output = Leaf of 'a list | Branch of 'a output * 'a output 6 | 7 | let output_to_seq o = 8 | let rec go o acc = 9 | match o with 10 | | Leaf l -> l @ acc 11 | | Branch (o1, o2) -> go o1 @@ go o2 acc 12 | in 13 | List.to_seq @@ go o [] 14 | 15 | module SequencerMonad = 16 | struct 17 | type 'a t = 'a * int output 18 | let ret x : _ t = x, Leaf [] 19 | let bind (m, o1) f : _ t = let x, o2 = f m in x, Branch (o1, o2) 20 | let yield x = (), Leaf [x] 21 | end 22 | 23 | module SequencerUnmonad = 24 | struct 25 | module U = Unmonad.Make (SequencerMonad) 26 | let yield x = U.perform (SequencerMonad.yield x) 27 | let run f = output_to_seq @@ snd @@ U.run f 28 | let register_printer _ = () 29 | end 30 | 31 | type cmd = Yield of int 32 | and prog = cmd list 33 | 34 | let gen_cmd = Q.Gen.map (fun i -> Yield i) Q.Gen.int 35 | let gen_prog = Q.Gen.list gen_cmd 36 | 37 | module SequencerTester (S : Algaeff.Sequencer.S with type elt := int) = 38 | struct 39 | let trace (prog : prog) = 40 | let go = function (Yield i) -> S.yield i in 41 | List.of_seq @@ S.run @@ fun () -> List.iter go prog 42 | end 43 | 44 | module SequencerEffTester = SequencerTester (SequencerEff) 45 | module SequencerUnmonadTester = SequencerTester (SequencerUnmonad) 46 | 47 | let test_prog = 48 | Q.Test.make ~name:"Sequencer" gen_prog 49 | (fun prog -> 50 | List.equal Int.equal 51 | (SequencerEffTester.trace prog) 52 | (SequencerUnmonadTester.trace prog)) 53 | 54 | let () = 55 | exit @@ 56 | QCheck_base_runner.run_tests ~colors:true ~verbose:true ~long:true 57 | [ test_prog ] 58 | -------------------------------------------------------------------------------- /test/TestSequencer.mli: -------------------------------------------------------------------------------- 1 | (* This file is intentionally blank to detect unused declarations. *) 2 | -------------------------------------------------------------------------------- /test/TestState.ml: -------------------------------------------------------------------------------- 1 | module Q = QCheck2 2 | 3 | module StateEff = Algaeff.State.Make (Int) 4 | 5 | module StateMonad = 6 | struct 7 | type 'a t = int -> 'a * int 8 | let ret x s = x, s 9 | let bind m f s = let x, s = m s in f x s 10 | let get s = s, s 11 | let set s _ = (), s 12 | let modify f s = (), f s 13 | end 14 | 15 | module StateUnmonad = 16 | struct 17 | module U = Unmonad.Make (StateMonad) 18 | let get () = U.perform StateMonad.get 19 | let set s = U.perform @@ StateMonad.set s 20 | let modify f = U.perform @@ StateMonad.modify f 21 | let run ~init f = fst @@ U.run f init 22 | let try_with ?get:_ ?set:_ _f = failwith "state monad can't try_with" 23 | let register_printer _ = () 24 | end 25 | 26 | type cmd = Set of int | GetAndPrint | Mod of (int -> int) 27 | 28 | let gen_cmd = 29 | let open Q.Gen in 30 | oneof 31 | [map (fun i -> Set i) int; 32 | pure GetAndPrint; 33 | map (fun (Q.Fun (_, f)) -> Mod f) (Q.fun1 Q.Observable.int int)] 34 | 35 | let gen_prog = Q.Gen.list gen_cmd 36 | 37 | module StateTester (S : Algaeff.State.S with type state := int) = 38 | struct 39 | let trace ~init prog = 40 | let go = 41 | function 42 | | Set i -> S.set i; [] 43 | | GetAndPrint -> [S.get ()] 44 | | Mod f -> S.modify f; [] 45 | in 46 | S.run ~init @@ fun () -> List.concat_map go prog 47 | end 48 | 49 | module StateEffTester = StateTester (StateEff) 50 | module StateUnmonadTester = StateTester (StateUnmonad) 51 | 52 | let test_prog = 53 | Q.Test.make ~name:"State" (Q.Gen.pair Q.Gen.int gen_prog) 54 | (fun (init, prog) -> 55 | List.equal Int.equal 56 | (StateEffTester.trace ~init prog) 57 | (StateUnmonadTester.trace ~init prog)) 58 | 59 | let () = 60 | exit @@ 61 | QCheck_base_runner.run_tests ~colors:true ~verbose:true ~long:true 62 | [ test_prog ] 63 | -------------------------------------------------------------------------------- /test/TestState.mli: -------------------------------------------------------------------------------- 1 | (* This file is intentionally blank to detect unused declarations. *) 2 | -------------------------------------------------------------------------------- /test/TestUniqueID.ml: -------------------------------------------------------------------------------- 1 | module Q = QCheck2 2 | 3 | module U = Algaeff.UniqueID.Make (Int) 4 | 5 | let test_uniqueness = 6 | Q.Test.make ~name:"UniqueID:uniqueness" Q.Gen.(list int) 7 | (fun l -> 8 | let ids = U.run @@ fun () -> List.map U.register l in 9 | List.length (List.sort_uniq U.ID.compare ids) = List.length ids) 10 | 11 | let test_retrieve = 12 | Q.Test.make ~name:"UniqueID:retrieval" Q.Gen.(list int) 13 | (fun l -> 14 | let ids, exported = U.run @@ fun () -> 15 | let ids = List.map U.register l in 16 | let exported = U.export () in 17 | ids, exported 18 | in 19 | let l' = U.run ~init:exported @@ fun () -> 20 | List.map U.retrieve ids 21 | in 22 | l = l') 23 | 24 | let () = 25 | exit @@ 26 | QCheck_base_runner.run_tests ~colors:true ~verbose:true ~long:true 27 | [ test_uniqueness 28 | ; test_retrieve 29 | ] 30 | -------------------------------------------------------------------------------- /test/TestUniqueID.mli: -------------------------------------------------------------------------------- 1 | (* This file is intentionally blank to detect unused declarations. *) 2 | -------------------------------------------------------------------------------- /test/Unmonad.ml: -------------------------------------------------------------------------------- 1 | module type Monad = 2 | sig 3 | type 'a t 4 | val ret : 'a -> 'a t 5 | val bind : 'a t -> ('a -> 'b t) -> 'b t 6 | end 7 | 8 | module type Param = Monad 9 | 10 | module type S = 11 | sig 12 | type 'a t 13 | val perform : 'a t -> 'a 14 | val run : (unit -> 'a) -> 'a t 15 | end 16 | 17 | module Make (M : Monad) = 18 | struct 19 | include M 20 | 21 | type 'a Effect.t += Monadic : 'a t -> 'a Effect.t 22 | 23 | let perform m = Effect.perform (Monadic m) 24 | let run f = 25 | Effect.Deep.match_with f () 26 | { retc = M.ret 27 | ; exnc = raise 28 | ; effc = function Monadic m -> Option.some @@ fun k -> M.bind m (Effect.Deep.continue k) | _ -> None 29 | } 30 | 31 | let () = Printexc.register_printer @@ function 32 | | Effect.Unhandled (Monadic _) -> Some "Unhandled algaeff effect; use Algaeff.Unmonad.run" 33 | | _ -> None 34 | end 35 | -------------------------------------------------------------------------------- /test/Unmonad.mli: -------------------------------------------------------------------------------- 1 | (** Effects for any monad (subject to OCaml continuations being one-shot). *) 2 | 3 | (** This is a general construction that uses effects to construct monadic expressions. 4 | Here is an alternative implementation of {!module:State} using the standard state monad: 5 | 6 | {[ 7 | module StateMonad = 8 | struct 9 | type state = int 10 | type 'a t = state -> 'a * state 11 | let ret x s = x, s 12 | let bind m f s = let x, s = m s in f x s 13 | let get s = s, s 14 | let set s _ = (), s 15 | let modify f s = (), f s 16 | end 17 | 18 | module StateUnmonad = 19 | struct 20 | type state = int 21 | module U = Algaeff.Unmonad.Make (StateMonad) 22 | let get () = U.perform StateMonad.get 23 | let set s = U.perform @@ StateMonad.set s 24 | let modify f = U.perform @@ StateMonad.modify f 25 | let run ~init f = fst @@ U.run f init 26 | end 27 | ]} 28 | 29 | Note that continuations in OCaml are one-shot, so the list monad will not work; 30 | it will quickly lead to the runtime error that the continuation is resumed twice. 31 | Also, monads do not mix well with exceptions, and thus the [bind] operation should not 32 | raise an exception unless it encounters a truly unrecoverable fatal error. Raising an exception 33 | within [bind] will skip the continuation, and thus potentially skipping exception handlers 34 | within the continuation. Those handlers might be crucial for properly releasing acquired resources. 35 | 36 | PS: We are not aware of any actual use of this module, but we decided to keep it anyway. 37 | *) 38 | 39 | module type Monad = 40 | sig 41 | (** The signature of monads. *) 42 | 43 | type 'a t 44 | val ret : 'a -> 'a t 45 | val bind : 'a t -> ('a -> 'b t) -> 'b t 46 | end 47 | 48 | module type Param = Monad 49 | (** Parameters of monad effects. *) 50 | 51 | module type S = 52 | sig 53 | (** Signatures of monad effects. *) 54 | 55 | type 'a t 56 | (** The monad. *) 57 | 58 | val perform : 'a t -> 'a 59 | (** Perform an monadic operation. *) 60 | 61 | val run : (unit -> 'a) -> 'a t 62 | (** [run t] runs the thunk [t] which may perform monad effects, 63 | and then returns the corresponding monadic expression. *) 64 | end 65 | 66 | module Make (M : Monad) : S with type 'a t := 'a M.t 67 | (** The implementation of monad effects. *) 68 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names TestState TestReader TestSequencer TestMutex TestUniqueID) 3 | (modules TestState TestReader TestSequencer TestMutex TestUniqueID Unmonad) 4 | (libraries qcheck-core qcheck-core.runner alcotest algaeff)) 5 | 6 | (test 7 | (name Example) 8 | (modules Example) 9 | (libraries algaeff)) 10 | --------------------------------------------------------------------------------