├── .github └── workflows │ ├── cabal.project.local │ └── ci.yaml ├── .gitignore ├── .travis.yml ├── ChangeLog.md ├── LICENSE ├── README.md ├── bench ├── Main.hs ├── report-O0.md ├── report-O1.md └── report-O2.md ├── cabal.project ├── examples ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── examples.cabal └── src │ └── LoginStateMachine.hs ├── free-category.cabal ├── src └── Control │ ├── Arrow │ └── Free.hs │ └── Category │ ├── Free.hs │ ├── Free │ └── Internal.hs │ └── FreeEffect.hs └── test ├── Main.hs └── Test ├── Cat.hs └── Queue.hs /.github/workflows/cabal.project.local: -------------------------------------------------------------------------------- 1 | documentation: True 2 | tests: True 3 | benchmarks: True 4 | 5 | package free-category 6 | ghc-options: -j2 -Werror 7 | -------------------------------------------------------------------------------- /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | pull_request: 5 | merge_group: 6 | 7 | jobs: 8 | build: 9 | runs-on: ${{ matrix.os }} 10 | 11 | defaults: 12 | run: 13 | shell: bash 14 | 15 | strategy: 16 | fail-fast: false 17 | matrix: 18 | ghc: ["8.10", "9.0", "9.2", "9.4", "9.6", "9.8", "9.10"] 19 | os: [ubuntu-latest] 20 | 21 | steps: 22 | - name: Install Haskell 23 | uses: haskell-actions/setup@v2 24 | id: setup-haskell 25 | with: 26 | ghc-version: ${{ matrix.ghc }} 27 | cabal-version: 3.8.1.0 28 | 29 | - name: Select build directory 30 | run: | 31 | if [ "$RUNNER_OS" == Windows ]; then 32 | CABAL_BUILDDIR="D:\\a\\_temp\\dist" 33 | else 34 | CABAL_BUILDDIR="dist-newstyle" 35 | fi 36 | 37 | echo "CABAL_BUILDDIR=$CABAL_BUILDDIR" 38 | echo "CABAL_BUILDDIR=$CABAL_BUILDDIR" >> $GITHUB_ENV 39 | 40 | - name: Set cache version 41 | run: echo "CACHE_VERSION=9w76Z3Q" >> $GITHUB_ENV 42 | 43 | - name: Set up temp directory 44 | env: 45 | RUNNER_TEMP: ${{ runner.temp }} 46 | run: | 47 | echo "TMPDIR=$RUNNER_TEMP" >> $GITHUB_ENV 48 | echo "TMP=$RUNNER_TEMP" >> $GITHUB_ENV 49 | 50 | - uses: actions/checkout@v4 51 | 52 | - name: Record dependencies 53 | id: record-deps 54 | run: | 55 | cabal build all --dry-run 56 | cat dist-newstyle/cache/plan.json | jq -r '."install-plan"[].id' | sort | uniq > dependencies.txt 57 | 58 | - name: Cache `cabal store` 59 | uses: actions/cache@v4 60 | with: 61 | path: ${{ steps.setup-haskell.outputs.cabal-store }} 62 | key: cabal-store-${{ env.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('dependencies.txt') }} 63 | restore-keys: cabal-store-${{ env.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }} 64 | 65 | - name: Cache `dist-newstyle` 66 | uses: actions/cache@v4 67 | with: 68 | path: | 69 | dist-newstyle 70 | !dist-newstyle/**/.git 71 | key: cache-dist-${{ env.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }} 72 | 73 | - name: Use cabal.project.local 74 | run: | 75 | cat .github/workflows/cabal.project.local >> ./cabal.project.local 76 | cat ./cabal.project.local 77 | 78 | - name: Build dependencies 79 | run: cabal --builddir="$CABAL_BUILDDIR" build --only-dependencies all 80 | 81 | - name: Build projects [build] 82 | run: cabal --builddir="$CABAL_BUILDDIR" build all 83 | 84 | - name: free-category [test] 85 | run: cabal --builddir="$CABAL_BUILDDIR" run free-category:test-cats 86 | 87 | - name: free-category [benchmarks] 88 | run: cabal build free-category:benchmarks 89 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .hie 2 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: nix 2 | script: 3 | - nix-env -iA cachix -f https://github.com/NixOS/nixpkgs/tarball/1d4de0d552ae9aa66a5b8dee5fb0650a4372d148 4 | - echo "trusted-users = root ${USER}" | sudo tee -a /etc/nix/nix.conf || true 5 | - sudo pkill nix-daemon || true 6 | - cachix use free-algebras 7 | - nix-build --arg dev true -A free-category --argstr compiler $COMPILER 8 | - cachix push free-algebras ./result 9 | matrix: 10 | include: 11 | - name: ghc865 12 | env: COMPILER="ghc865" 13 | - name: ghc844 14 | env: COMPILER="ghc844" 15 | - name: ghc822 16 | env: COMPILER="ghc822" 17 | - name: ghc802 18 | env: COMPILER="ghc802" 19 | 20 | # - name: ghc861 21 | # env: COMPILER="ghc861" 22 | # os: osx 23 | - name: ghc844 24 | env: COMPILER="ghc844" 25 | os: osx 26 | # - name: ghc822 27 | # env: COMPILER="ghc822" 28 | # os: osx 29 | - name: ghc802 30 | env: COMPILER="ghc802" 31 | os: osx 32 | env: 33 | global: 34 | secure: ecJWxKZzeiSkp5WDSbQqcCnBOqsyXrdW+q+xqiNU39BVLpkTSFs3+F+UYL9f+dOSJEsSzKk4H2ELJgKIWvADsugJw2sm6QCx29ONO8v/K6YZj5srT7zUyqYcaSWnyYhEBfG3szm2fPkFLye5sOSUQ1TZY5GQLWiUS8cepx9YqtFDe5T7ynRHX9SsKwFj2cJXr4jju+x/5RSzGhgq5rCr5TlA0lMLZsz/K2nSheRfaPelFVQDBMHfepXl/U4w8WpdKEbep1zNiuGUGDcwytQ6lA8inA58maOk13O4/Zo5qmDXM0U2iLr6jOe1Y8orfcxoiVuXfbzGDmI+EEJaXd9uxSqd6/jol5/k9Bp1WdG7azRYC8fu0YMTtlKQ3pcUQApp17fm9RkboIJOHYXEcBljJk3tZdJKx/6cY9/i7kBbVrglZhUOLz5YllxIXwzHQXsiQMb4O+7JNGUo6fRcDKS8YKACDgkiPRoV1s2ills8bI9lY6sSS85WbyQzhCsi6LmZdDIaSRpcTJ8Q41+qiiI+DbLuA8CauZLJfSTgjMRXL+ugv0dZ4jGhlVEqrb4X/Je9+0J4Vy3SmtcN0o2HzaNp8pcnZkwPUn4z9p7IU05P7eT1RGwWGxiN8dBrpeexiZbMDZzDj/XrC5zEyvz6eV/xKSXEDMCJsjuWg4YQR+m8cQs= 35 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for free-category 2 | 3 | ## Version 0.0.4.5 4 | - Support `GHC-9.6`. 5 | - Export `Arr` all constructors. 6 | 7 | ## Version 0.0.4.4 8 | - Added support for GHC: `9.0`, `9.2`, `9.4`. 9 | - Dropped support for `GHC-8.6` or earlier. 10 | - Added ArrChoice a free ArrowChoice. 11 | 12 | ## Version 0.0.4.2 13 | - updated for *GHC 8.10.1* 14 | 15 | ## Version 0.0.4.0 16 | - hoistOp 17 | - Renamed `Control.Category.FreeEff` module as `Control.Category.FreeEffect` 18 | and renamed top level terms: 19 | - `EffCategory` type class to `EffectCategory` 20 | - `FreeEffCat` to `EffCat` 21 | - `FreeEffCat` constructor as `Effect` and `lift` as `effect` 22 | - `liftCat` to `liftEffect` 23 | - `foldNatLift` to `foldNatEffCat` 24 | - Show instance of 'Cat' and 'C' via 'ListTr' (GHC >= 806) 25 | - Performance optimisations: rewrite rules & inline pragmas 26 | - Export ListTr from Control.Category.Free 27 | - foldrL, foldlL and zipWithL 28 | 29 | ## Version 0.0.3.0 30 | - Efficient 'Cat' and 'Aff' based on real time queues with scheduling 31 | - Added Monoid instances 32 | - Added Op category 33 | - added `arrArr`, `mapArr`, `foldArr` for `Arr` free arrow category 34 | - added `arrCat`, `mapCat`, `fodlMap` for `Cat` free categroy 35 | 36 | ## Version 0.0.2.0 37 | 38 | - EffCategory class and FreeEffCat category transformer 39 | - Example usage of FreeEffCat 40 | 41 | ## Version 0.0.1.0 42 | - free category (concrete and condensity transformed) 43 | - free arrows (concrete and condensity transformed) 44 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Mozilla Public License Version 2.0 2 | ================================== 3 | 4 | 1. Definitions 5 | -------------- 6 | 7 | 1.1. "Contributor" 8 | means each individual or legal entity that creates, contributes to 9 | the creation of, or owns Covered Software. 10 | 11 | 1.2. "Contributor Version" 12 | means the combination of the Contributions of others (if any) used 13 | by a Contributor and that particular Contributor's Contribution. 14 | 15 | 1.3. "Contribution" 16 | means Covered Software of a particular Contributor. 17 | 18 | 1.4. "Covered Software" 19 | means Source Code Form to which the initial Contributor has attached 20 | the notice in Exhibit A, the Executable Form of such Source Code 21 | Form, and Modifications of such Source Code Form, in each case 22 | including portions thereof. 23 | 24 | 1.5. "Incompatible With Secondary Licenses" 25 | means 26 | 27 | (a) that the initial Contributor has attached the notice described 28 | in Exhibit B to the Covered Software; or 29 | 30 | (b) that the Covered Software was made available under the terms of 31 | version 1.1 or earlier of the License, but not also under the 32 | terms of a Secondary License. 33 | 34 | 1.6. "Executable Form" 35 | means any form of the work other than Source Code Form. 36 | 37 | 1.7. "Larger Work" 38 | means a work that combines Covered Software with other material, in 39 | a separate file or files, that is not Covered Software. 40 | 41 | 1.8. "License" 42 | means this document. 43 | 44 | 1.9. "Licensable" 45 | means having the right to grant, to the maximum extent possible, 46 | whether at the time of the initial grant or subsequently, any and 47 | all of the rights conveyed by this License. 48 | 49 | 1.10. "Modifications" 50 | means any of the following: 51 | 52 | (a) any file in Source Code Form that results from an addition to, 53 | deletion from, or modification of the contents of Covered 54 | Software; or 55 | 56 | (b) any new file in Source Code Form that contains any Covered 57 | Software. 58 | 59 | 1.11. "Patent Claims" of a Contributor 60 | means any patent claim(s), including without limitation, method, 61 | process, and apparatus claims, in any patent Licensable by such 62 | Contributor that would be infringed, but for the grant of the 63 | License, by the making, using, selling, offering for sale, having 64 | made, import, or transfer of either its Contributions or its 65 | Contributor Version. 66 | 67 | 1.12. "Secondary License" 68 | means either the GNU General Public License, Version 2.0, the GNU 69 | Lesser General Public License, Version 2.1, the GNU Affero General 70 | Public License, Version 3.0, or any later versions of those 71 | licenses. 72 | 73 | 1.13. "Source Code Form" 74 | means the form of the work preferred for making modifications. 75 | 76 | 1.14. "You" (or "Your") 77 | means an individual or a legal entity exercising rights under this 78 | License. For legal entities, "You" includes any entity that 79 | controls, is controlled by, or is under common control with You. For 80 | purposes of this definition, "control" means (a) the power, direct 81 | or indirect, to cause the direction or management of such entity, 82 | whether by contract or otherwise, or (b) ownership of more than 83 | fifty percent (50%) of the outstanding shares or beneficial 84 | ownership of such entity. 85 | 86 | 2. License Grants and Conditions 87 | -------------------------------- 88 | 89 | 2.1. Grants 90 | 91 | Each Contributor hereby grants You a world-wide, royalty-free, 92 | non-exclusive license: 93 | 94 | (a) under intellectual property rights (other than patent or trademark) 95 | Licensable by such Contributor to use, reproduce, make available, 96 | modify, display, perform, distribute, and otherwise exploit its 97 | Contributions, either on an unmodified basis, with Modifications, or 98 | as part of a Larger Work; and 99 | 100 | (b) under Patent Claims of such Contributor to make, use, sell, offer 101 | for sale, have made, import, and otherwise transfer either its 102 | Contributions or its Contributor Version. 103 | 104 | 2.2. Effective Date 105 | 106 | The licenses granted in Section 2.1 with respect to any Contribution 107 | become effective for each Contribution on the date the Contributor first 108 | distributes such Contribution. 109 | 110 | 2.3. Limitations on Grant Scope 111 | 112 | The licenses granted in this Section 2 are the only rights granted under 113 | this License. No additional rights or licenses will be implied from the 114 | distribution or licensing of Covered Software under this License. 115 | Notwithstanding Section 2.1(b) above, no patent license is granted by a 116 | Contributor: 117 | 118 | (a) for any code that a Contributor has removed from Covered Software; 119 | or 120 | 121 | (b) for infringements caused by: (i) Your and any other third party's 122 | modifications of Covered Software, or (ii) the combination of its 123 | Contributions with other software (except as part of its Contributor 124 | Version); or 125 | 126 | (c) under Patent Claims infringed by Covered Software in the absence of 127 | its Contributions. 128 | 129 | This License does not grant any rights in the trademarks, service marks, 130 | or logos of any Contributor (except as may be necessary to comply with 131 | the notice requirements in Section 3.4). 132 | 133 | 2.4. Subsequent Licenses 134 | 135 | No Contributor makes additional grants as a result of Your choice to 136 | distribute the Covered Software under a subsequent version of this 137 | License (see Section 10.2) or under the terms of a Secondary License (if 138 | permitted under the terms of Section 3.3). 139 | 140 | 2.5. Representation 141 | 142 | Each Contributor represents that the Contributor believes its 143 | Contributions are its original creation(s) or it has sufficient rights 144 | to grant the rights to its Contributions conveyed by this License. 145 | 146 | 2.6. Fair Use 147 | 148 | This License is not intended to limit any rights You have under 149 | applicable copyright doctrines of fair use, fair dealing, or other 150 | equivalents. 151 | 152 | 2.7. Conditions 153 | 154 | Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted 155 | in Section 2.1. 156 | 157 | 3. Responsibilities 158 | ------------------- 159 | 160 | 3.1. Distribution of Source Form 161 | 162 | All distribution of Covered Software in Source Code Form, including any 163 | Modifications that You create or to which You contribute, must be under 164 | the terms of this License. You must inform recipients that the Source 165 | Code Form of the Covered Software is governed by the terms of this 166 | License, and how they can obtain a copy of this License. You may not 167 | attempt to alter or restrict the recipients' rights in the Source Code 168 | Form. 169 | 170 | 3.2. Distribution of Executable Form 171 | 172 | If You distribute Covered Software in Executable Form then: 173 | 174 | (a) such Covered Software must also be made available in Source Code 175 | Form, as described in Section 3.1, and You must inform recipients of 176 | the Executable Form how they can obtain a copy of such Source Code 177 | Form by reasonable means in a timely manner, at a charge no more 178 | than the cost of distribution to the recipient; and 179 | 180 | (b) You may distribute such Executable Form under the terms of this 181 | License, or sublicense it under different terms, provided that the 182 | license for the Executable Form does not attempt to limit or alter 183 | the recipients' rights in the Source Code Form under this License. 184 | 185 | 3.3. Distribution of a Larger Work 186 | 187 | You may create and distribute a Larger Work under terms of Your choice, 188 | provided that You also comply with the requirements of this License for 189 | the Covered Software. If the Larger Work is a combination of Covered 190 | Software with a work governed by one or more Secondary Licenses, and the 191 | Covered Software is not Incompatible With Secondary Licenses, this 192 | License permits You to additionally distribute such Covered Software 193 | under the terms of such Secondary License(s), so that the recipient of 194 | the Larger Work may, at their option, further distribute the Covered 195 | Software under the terms of either this License or such Secondary 196 | License(s). 197 | 198 | 3.4. Notices 199 | 200 | You may not remove or alter the substance of any license notices 201 | (including copyright notices, patent notices, disclaimers of warranty, 202 | or limitations of liability) contained within the Source Code Form of 203 | the Covered Software, except that You may alter any license notices to 204 | the extent required to remedy known factual inaccuracies. 205 | 206 | 3.5. Application of Additional Terms 207 | 208 | You may choose to offer, and to charge a fee for, warranty, support, 209 | indemnity or liability obligations to one or more recipients of Covered 210 | Software. However, You may do so only on Your own behalf, and not on 211 | behalf of any Contributor. You must make it absolutely clear that any 212 | such warranty, support, indemnity, or liability obligation is offered by 213 | You alone, and You hereby agree to indemnify every Contributor for any 214 | liability incurred by such Contributor as a result of warranty, support, 215 | indemnity or liability terms You offer. You may include additional 216 | disclaimers of warranty and limitations of liability specific to any 217 | jurisdiction. 218 | 219 | 4. Inability to Comply Due to Statute or Regulation 220 | --------------------------------------------------- 221 | 222 | If it is impossible for You to comply with any of the terms of this 223 | License with respect to some or all of the Covered Software due to 224 | statute, judicial order, or regulation then You must: (a) comply with 225 | the terms of this License to the maximum extent possible; and (b) 226 | describe the limitations and the code they affect. Such description must 227 | be placed in a text file included with all distributions of the Covered 228 | Software under this License. Except to the extent prohibited by statute 229 | or regulation, such description must be sufficiently detailed for a 230 | recipient of ordinary skill to be able to understand it. 231 | 232 | 5. Termination 233 | -------------- 234 | 235 | 5.1. The rights granted under this License will terminate automatically 236 | if You fail to comply with any of its terms. However, if You become 237 | compliant, then the rights granted under this License from a particular 238 | Contributor are reinstated (a) provisionally, unless and until such 239 | Contributor explicitly and finally terminates Your grants, and (b) on an 240 | ongoing basis, if such Contributor fails to notify You of the 241 | non-compliance by some reasonable means prior to 60 days after You have 242 | come back into compliance. Moreover, Your grants from a particular 243 | Contributor are reinstated on an ongoing basis if such Contributor 244 | notifies You of the non-compliance by some reasonable means, this is the 245 | first time You have received notice of non-compliance with this License 246 | from such Contributor, and You become compliant prior to 30 days after 247 | Your receipt of the notice. 248 | 249 | 5.2. If You initiate litigation against any entity by asserting a patent 250 | infringement claim (excluding declaratory judgment actions, 251 | counter-claims, and cross-claims) alleging that a Contributor Version 252 | directly or indirectly infringes any patent, then the rights granted to 253 | You by any and all Contributors for the Covered Software under Section 254 | 2.1 of this License shall terminate. 255 | 256 | 5.3. In the event of termination under Sections 5.1 or 5.2 above, all 257 | end user license agreements (excluding distributors and resellers) which 258 | have been validly granted by You or Your distributors under this License 259 | prior to termination shall survive termination. 260 | 261 | ************************************************************************ 262 | * * 263 | * 6. Disclaimer of Warranty * 264 | * ------------------------- * 265 | * * 266 | * Covered Software is provided under this License on an "as is" * 267 | * basis, without warranty of any kind, either expressed, implied, or * 268 | * statutory, including, without limitation, warranties that the * 269 | * Covered Software is free of defects, merchantable, fit for a * 270 | * particular purpose or non-infringing. The entire risk as to the * 271 | * quality and performance of the Covered Software is with You. * 272 | * Should any Covered Software prove defective in any respect, You * 273 | * (not any Contributor) assume the cost of any necessary servicing, * 274 | * repair, or correction. This disclaimer of warranty constitutes an * 275 | * essential part of this License. No use of any Covered Software is * 276 | * authorized under this License except under this disclaimer. * 277 | * * 278 | ************************************************************************ 279 | 280 | ************************************************************************ 281 | * * 282 | * 7. Limitation of Liability * 283 | * -------------------------- * 284 | * * 285 | * Under no circumstances and under no legal theory, whether tort * 286 | * (including negligence), contract, or otherwise, shall any * 287 | * Contributor, or anyone who distributes Covered Software as * 288 | * permitted above, be liable to You for any direct, indirect, * 289 | * special, incidental, or consequential damages of any character * 290 | * including, without limitation, damages for lost profits, loss of * 291 | * goodwill, work stoppage, computer failure or malfunction, or any * 292 | * and all other commercial damages or losses, even if such party * 293 | * shall have been informed of the possibility of such damages. This * 294 | * limitation of liability shall not apply to liability for death or * 295 | * personal injury resulting from such party's negligence to the * 296 | * extent applicable law prohibits such limitation. Some * 297 | * jurisdictions do not allow the exclusion or limitation of * 298 | * incidental or consequential damages, so this exclusion and * 299 | * limitation may not apply to You. * 300 | * * 301 | ************************************************************************ 302 | 303 | 8. Litigation 304 | ------------- 305 | 306 | Any litigation relating to this License may be brought only in the 307 | courts of a jurisdiction where the defendant maintains its principal 308 | place of business and such litigation shall be governed by laws of that 309 | jurisdiction, without reference to its conflict-of-law provisions. 310 | Nothing in this Section shall prevent a party's ability to bring 311 | cross-claims or counter-claims. 312 | 313 | 9. Miscellaneous 314 | ---------------- 315 | 316 | This License represents the complete agreement concerning the subject 317 | matter hereof. If any provision of this License is held to be 318 | unenforceable, such provision shall be reformed only to the extent 319 | necessary to make it enforceable. Any law or regulation which provides 320 | that the language of a contract shall be construed against the drafter 321 | shall not be used to construe this License against a Contributor. 322 | 323 | 10. Versions of the License 324 | --------------------------- 325 | 326 | 10.1. New Versions 327 | 328 | Mozilla Foundation is the license steward. Except as provided in Section 329 | 10.3, no one other than the license steward has the right to modify or 330 | publish new versions of this License. Each version will be given a 331 | distinguishing version number. 332 | 333 | 10.2. Effect of New Versions 334 | 335 | You may distribute the Covered Software under the terms of the version 336 | of the License under which You originally received the Covered Software, 337 | or under the terms of any subsequent version published by the license 338 | steward. 339 | 340 | 10.3. Modified Versions 341 | 342 | If you create software not governed by this License, and you want to 343 | create a new license for such software, you may create and use a 344 | modified version of this License if you rename the license and remove 345 | any references to the name of the license steward (except to note that 346 | such modified license differs from this License). 347 | 348 | 10.4. Distributing Source Code Form that is Incompatible With Secondary 349 | Licenses 350 | 351 | If You choose to distribute Source Code Form that is Incompatible With 352 | Secondary Licenses under the terms of this version of the License, the 353 | notice described in Exhibit B of this License must be attached. 354 | 355 | Exhibit A - Source Code Form License Notice 356 | ------------------------------------------- 357 | 358 | This Source Code Form is subject to the terms of the Mozilla Public 359 | License, v. 2.0. If a copy of the MPL was not distributed with this 360 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 361 | 362 | If it is not possible or desirable to put the notice in a particular 363 | file, then You may include the notice in a location (such as a LICENSE 364 | file in a relevant directory) where a recipient would be likely to look 365 | for such a notice. 366 | 367 | You may add additional accurate notices of copyright ownership. 368 | 369 | Exhibit B - "Incompatible With Secondary Licenses" Notice 370 | --------------------------------------------------------- 371 | 372 | This Source Code Form is "Incompatible With Secondary Licenses", as 373 | defined by the Mozilla Public License, v. 2.0. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Free Category 2 | [![Maintainer: coot](https://img.shields.io/badge/maintainer-coot-lightgrey.svg?style=for-the-badge)](http://github.com/coot) 3 | [![Haskell/CI](https://img.shields.io/github/actions/workflow/status/coot/free-category/ci.yaml?branch=master&label=Build&style=for-the-badge)](https://github.com/coot/free-category/actions) 4 | 5 | This package contains efficient implementations of free categories. There are 6 | various representations available: 7 | 8 | * real-time queues (C. Okasaki 'Pure Functional Data Structures') 9 | * type aligned lists 10 | * continuation passing style (Church encoding) 11 | 12 | Free arrows and free Kleisli categories are also included. 13 | 14 | Free categories are useful to model state machines in a simple yet type safe 15 | manner. For that purpose `Kleisli` categories are a very useful target which 16 | allows to include monadic computations. This package contains a useful 17 | generalisation of `Kleisli` categories captured by `EffectCategory` class 18 | (categories with effects), and a (free) transformer which lifts a category to 19 | a category with effects. 20 | 21 | ## Benchmarks 22 | 23 | Check performance characteristics of various representations: 24 | 25 | * [report-O0](/bench/report-O0.md) 26 | * [report-O1](/bench/report-O1.md) 27 | * [report-O2](/bench/report-O2.md) 28 | 29 | ## Resources 30 | * [LoginStateMachine](https://github.com/coot/free-category/blob/master/examples/src/LoginStateMachine.hs): 31 | based on [State Machines All The Way 32 | Down](https://www.youtube.com/watch?v=xq7ZuSRgCR4) by Edwin Bradly, 2017. 33 | You can run it with `cabal new-run examples:login-state-machine`. 34 | * Read more [here](https://coot.me/posts/finite-state-machines.html) on 35 | a simple example of a finite state machine encoded using a free category 36 | using a simple GADT. 37 | * Another 38 | [example](https://github.com/coot/free-algebras/blob/master/examples/src/Control/Category/Free.hs). 39 | * [Blog post](https://coot.me/posts/kleisli-categories-and-free-monads.html) on Kleisli categories. 40 | -------------------------------------------------------------------------------- /bench/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GADTs #-} 3 | 4 | module Main where 5 | 6 | import Prelude hiding (id, (.)) 7 | import Control.Category 8 | import Data.Foldable (foldl') 9 | 10 | import Control.Category.Free 11 | import Control.Category.Free.Internal 12 | 13 | import Criterion 14 | import Criterion.Main 15 | 16 | 17 | data Alg a b where 18 | Add :: !Int -> Alg Int Int 19 | Mul :: !Int -> Alg Int Int 20 | 21 | instance Show (Alg a b) where 22 | show (Add i) = "Add " ++ show i 23 | show (Mul i) = "Mul " ++ show i 24 | 25 | interpret :: Alg a b -> a -> b 26 | interpret (Add i) = (+i) 27 | interpret (Mul i) = (*i) 28 | 29 | -- foldr on outer and inner lists 30 | fromListR :: Category (f Alg) => (Int -> f Alg Int Int) -> [[Int]] -> f Alg Int Int 31 | fromListR f = foldr (\is c -> foldr (\i c' -> f i . c') id is . c) id 32 | 33 | -- foldr on outer and foldl on inner list 34 | fromListRL :: Category (f Alg) => (Int -> f Alg Int Int) -> [[Int]] -> f Alg Int Int 35 | fromListRL f = foldr (\is c -> foldl (\c' i -> c' . f i) id is . c) id 36 | 37 | -- foldl on outer and inner loop 38 | fromListL :: Category (f Alg) => (Int -> f Alg Int Int) -> [[Int]] -> f Alg Int Int 39 | fromListL f = foldl' (\c is -> c . foldl' (\c' i -> c' . f i) id is) id 40 | 41 | -- foldl on outer and foldr on inner loop 42 | fromListLR :: Category (f Alg) => (Int -> f Alg Int Int) -> [[Int]] -> f Alg Int Int 43 | fromListLR f = foldr (\is c -> foldl' (\c' i -> c' . f i) id is . c) id 44 | 45 | -- alternate foldl and foldr 46 | fromListM' :: Category (f Alg) => (Int -> f Alg Int Int) -> [Int] -> f Alg Int Int 47 | fromListM' f is = foldl' (\c (i, x) -> if x then c . f i 48 | else f i . c) 49 | id (zip is (concat $ repeat [True, False])) 50 | 51 | -- alternate foldl and foldr 52 | fromListM :: Category (f Alg) => (Int -> f Alg Int Int) -> [[Int]] -> f Alg Int Int 53 | fromListM f iss = foldl' (\c (is, x) -> if x then c . fromListM' f is 54 | else fromListM' f is . c) 55 | id (zip iss (concat $ repeat [True, False])) 56 | 57 | setupEnv100 :: [[Int]] 58 | setupEnv100 = replicate 100 [1..100] 59 | 60 | setupEnv250 :: [[Int]] 61 | setupEnv250 = replicate 250 [1..250] 62 | 63 | setupEnv500 :: [[Int]] 64 | setupEnv500 = replicate 500 [1..500] 65 | 66 | main :: IO () 67 | main = defaultMain 68 | [ env (pure setupEnv100) $ \ints -> bgroup "main" 69 | [ bgroup "Queue 100" 70 | [ bench "right right" $ 71 | whnf 72 | (\c -> foldNatQ interpret c 0) 73 | (fromListR (\i -> liftQ (Add i)) ints) 74 | , bench "right left" $ 75 | whnf 76 | (\c -> foldNatQ interpret c 0) 77 | (fromListRL (\i -> liftQ (Add i)) ints) 78 | , bench "left left " $ 79 | whnf 80 | (\c -> foldNatQ interpret c 0) 81 | (fromListL (\i -> liftQ (Add i)) ints) 82 | , bench "left right" $ 83 | whnf 84 | (\c -> foldNatQ interpret c 0) 85 | (fromListLR (\i -> liftQ (Add i)) ints) 86 | , bench "alternate " $ 87 | whnf 88 | (\c -> foldNatQ interpret c 0) 89 | (fromListM (\i -> liftQ (Add i)) ints) 90 | ] 91 | 92 | , bgroup "ListTr 100" 93 | [ bench "right right" $ 94 | whnf 95 | (\c -> foldNatL interpret c 0) 96 | (fromListR (\i -> liftL (Add i)) ints) 97 | , bench "right left" $ 98 | whnf 99 | (\c -> foldNatL interpret c 0) 100 | (fromListRL (\i -> liftL (Add i)) ints) 101 | , bench "left left " $ 102 | whnf 103 | (\c -> foldNatL interpret c 0) 104 | (fromListL (\i -> liftL (Add i)) ints) 105 | , bench "left right" $ 106 | whnf 107 | (\c -> foldNatL interpret c 0) 108 | (fromListLR (\i -> liftL (Add i)) ints) 109 | , bench "alternate " $ 110 | whnf 111 | (\c -> foldNatL interpret c 0) 112 | (fromListM (\i -> ConsTr (Add i) NilTr) ints) 113 | ] 114 | 115 | , bgroup "C 100" 116 | [ bench "right right" $ 117 | whnf 118 | (\c -> foldNatFree2 interpret c 0) 119 | (fromListR ((\i -> C $ \k -> k (Add i))) ints) 120 | , bench "right left" $ 121 | whnf 122 | (\c -> foldNatFree2 interpret c 0) 123 | (fromListRL ((\i -> C $ \k -> k (Add i))) ints) 124 | , bench "left left" $ 125 | whnf 126 | (\c -> foldNatFree2 interpret c 0) 127 | (fromListL ((\i -> C $ \k -> k (Add i))) ints) 128 | , bench "left right" $ 129 | whnf 130 | (\c -> foldNatFree2 interpret c 0) 131 | (fromListLR ((\i -> C $ \k -> k (Add i))) ints) 132 | , bench "alternate" $ 133 | whnf 134 | (\c -> foldNatFree2 interpret c 0) 135 | (fromListM ((\i -> C $ \k -> k (Add i))) ints) 136 | ] 137 | ] 138 | , env (pure setupEnv250) $ \ints -> bgroup "main" 139 | [ bgroup "Queue 250" 140 | [ bench "right right" $ 141 | whnf 142 | (\c -> foldNatQ interpret c 0) 143 | (fromListR (\i -> liftQ (Add i)) ints) 144 | ] 145 | 146 | , bgroup "ListTr 250" 147 | [ bench "right right" $ 148 | whnf 149 | (\c -> foldNatL interpret c 0) 150 | (fromListR (\i -> liftL (Add i)) ints) 151 | ] 152 | 153 | {-- 154 | - , bgroup "C 250" 155 | - [ bench "right right" $ 156 | - whnf 157 | - (\c -> foldNatFree2 interpret c 0) 158 | - (fromListR ((\i -> C $ \k -> k (Add i))) ints) 159 | - ] 160 | --} 161 | ] 162 | , env (pure setupEnv500) $ \ints -> bgroup "main" 163 | [ bgroup "Queue 500" 164 | [ bench "right right" $ 165 | whnf 166 | (\c -> foldNatQ interpret c 0) 167 | (fromListR (\i -> liftQ (Add i)) ints) 168 | ] 169 | 170 | , bgroup "ListTr 500" 171 | [ bench "right right" $ 172 | whnf 173 | (\c -> foldNatL interpret c 0) 174 | (fromListR (\i -> liftL (Add i)) ints) 175 | ] 176 | 177 | {-- 178 | - , bgroup "C 500" 179 | - [ bench "right right" $ 180 | - whnf 181 | - (\c -> foldNatFree2 interpret c 0) 182 | - (fromListR ((\i -> C $ \k -> k (Add i))) ints) 183 | - ] 184 | --} 185 | ] 186 | ] 187 | 188 | -------------------------------------------------------------------------------- /bench/report-O0.md: -------------------------------------------------------------------------------- 1 | ``` 2 | cabal run -O0 bench-cats 3 | benchmarking main/Queue 100/right right 4 | time 1.141 ms (1.138 ms .. 1.143 ms) 5 | 1.000 R² (1.000 R² .. 1.000 R²) 6 | mean 1.140 ms (1.138 ms .. 1.143 ms) 7 | std dev 8.646 μs (6.948 μs .. 11.22 μs) 8 | 9 | benchmarking main/Queue 100/right left 10 | time 1.141 ms (1.136 ms .. 1.147 ms) 11 | 1.000 R² (1.000 R² .. 1.000 R²) 12 | mean 1.138 ms (1.135 ms .. 1.142 ms) 13 | std dev 10.92 μs (8.393 μs .. 15.79 μs) 14 | 15 | benchmarking main/Queue 100/left left 16 | time 1.142 ms (1.139 ms .. 1.146 ms) 17 | 1.000 R² (1.000 R² .. 1.000 R²) 18 | mean 1.142 ms (1.138 ms .. 1.147 ms) 19 | std dev 14.64 μs (11.59 μs .. 19.91 μs) 20 | 21 | benchmarking main/Queue 100/left right 22 | time 1.141 ms (1.136 ms .. 1.147 ms) 23 | 1.000 R² (1.000 R² .. 1.000 R²) 24 | mean 1.141 ms (1.137 ms .. 1.148 ms) 25 | std dev 16.67 μs (9.879 μs .. 29.72 μs) 26 | 27 | benchmarking main/Queue 100/alternate 28 | time 1.164 ms (1.153 ms .. 1.185 ms) 29 | 0.983 R² (0.951 R² .. 0.999 R²) 30 | mean 1.188 ms (1.159 ms .. 1.290 ms) 31 | std dev 158.9 μs (71.22 μs .. 324.6 μs) 32 | variance introduced by outliers: 83% (severely inflated) 33 | 34 | benchmarking main/ListTr 100/right right 35 | time 700.0 μs (691.4 μs .. 706.7 μs) 36 | 0.997 R² (0.993 R² .. 0.999 R²) 37 | mean 756.8 μs (718.7 μs .. 906.9 μs) 38 | std dev 245.7 μs (9.661 μs .. 523.4 μs) 39 | variance introduced by outliers: 97% (severely inflated) 40 | 41 | benchmarking main/ListTr 100/right left 42 | time 756.6 μs (717.7 μs .. 812.2 μs) 43 | 0.980 R² (0.959 R² .. 1.000 R²) 44 | mean 719.7 μs (710.8 μs .. 755.0 μs) 45 | std dev 48.82 μs (9.722 μs .. 100.7 μs) 46 | variance introduced by outliers: 57% (severely inflated) 47 | 48 | benchmarking main/ListTr 100/left left 49 | time 767.3 μs (723.7 μs .. 813.2 μs) 50 | 0.983 R² (0.968 R² .. 1.000 R²) 51 | mean 733.7 μs (723.2 μs .. 762.2 μs) 52 | std dev 51.61 μs (22.86 μs .. 96.08 μs) 53 | variance introduced by outliers: 59% (severely inflated) 54 | 55 | benchmarking main/ListTr 100/left right 56 | time 717.4 μs (715.5 μs .. 719.9 μs) 57 | 1.000 R² (1.000 R² .. 1.000 R²) 58 | mean 718.1 μs (716.1 μs .. 721.1 μs) 59 | std dev 7.838 μs (5.645 μs .. 12.14 μs) 60 | 61 | benchmarking main/ListTr 100/alternate 62 | time 715.4 μs (712.1 μs .. 720.6 μs) 63 | 1.000 R² (1.000 R² .. 1.000 R²) 64 | mean 715.6 μs (713.4 μs .. 719.0 μs) 65 | std dev 8.725 μs (6.633 μs .. 11.88 μs) 66 | 67 | benchmarking main/C 100/right right 68 | time 899.4 μs (894.7 μs .. 905.2 μs) 69 | 1.000 R² (1.000 R² .. 1.000 R²) 70 | mean 902.1 μs (898.5 μs .. 906.9 μs) 71 | std dev 13.97 μs (10.79 μs .. 19.73 μs) 72 | 73 | benchmarking main/C 100/right left 74 | time 903.2 μs (895.5 μs .. 911.5 μs) 75 | 0.999 R² (0.999 R² .. 1.000 R²) 76 | mean 900.8 μs (896.2 μs .. 909.6 μs) 77 | std dev 20.72 μs (14.03 μs .. 33.73 μs) 78 | variance introduced by outliers: 13% (moderately inflated) 79 | 80 | benchmarking main/C 100/left left 81 | time 1.213 ms (1.199 ms .. 1.241 ms) 82 | 0.982 R² (0.955 R² .. 0.999 R²) 83 | mean 1.236 ms (1.204 ms .. 1.320 ms) 84 | std dev 159.4 μs (51.06 μs .. 269.7 μs) 85 | variance introduced by outliers: 81% (severely inflated) 86 | 87 | benchmarking main/C 100/left right 88 | time 898.3 μs (854.1 μs .. 969.1 μs) 89 | 0.970 R² (0.951 R² .. 0.992 R²) 90 | mean 925.6 μs (903.9 μs .. 959.2 μs) 91 | std dev 89.03 μs (60.65 μs .. 138.8 μs) 92 | variance introduced by outliers: 72% (severely inflated) 93 | 94 | benchmarking main/C 100/alternate 95 | time 1.075 ms (1.063 ms .. 1.093 ms) 96 | 0.996 R² (0.992 R² .. 0.999 R²) 97 | mean 1.085 ms (1.071 ms .. 1.109 ms) 98 | std dev 58.94 μs (35.22 μs .. 85.70 μs) 99 | variance introduced by outliers: 43% (moderately inflated) 100 | 101 | benchmarking main/Queue 250/right right 102 | time 8.210 ms (8.158 ms .. 8.283 ms) 103 | 1.000 R² (0.999 R² .. 1.000 R²) 104 | mean 8.104 ms (8.050 ms .. 8.148 ms) 105 | std dev 141.8 μs (100.5 μs .. 213.6 μs) 106 | 107 | benchmarking main/ListTr 250/right right 108 | time 6.835 ms (6.677 ms .. 7.059 ms) 109 | 0.997 R² (0.994 R² .. 1.000 R²) 110 | mean 6.631 ms (6.592 ms .. 6.697 ms) 111 | std dev 151.1 μs (73.51 μs .. 274.0 μs) 112 | 113 | benchmarking main/Queue 500/right right 114 | time 33.14 ms (32.12 ms .. 34.38 ms) 115 | 0.995 R² (0.984 R² .. 0.999 R²) 116 | mean 33.84 ms (33.06 ms .. 34.85 ms) 117 | std dev 1.819 ms (1.173 ms .. 2.736 ms) 118 | variance introduced by outliers: 18% (moderately inflated) 119 | 120 | benchmarking main/ListTr 500/right right 121 | time 28.88 ms (27.92 ms .. 30.42 ms) 122 | 0.983 R² (0.944 R² .. 0.999 R²) 123 | mean 29.04 ms (28.51 ms .. 30.34 ms) 124 | std dev 1.758 ms (608.9 μs .. 3.384 ms) 125 | variance introduced by outliers: 21% (moderately inflated) 126 | ``` 127 | -------------------------------------------------------------------------------- /bench/report-O1.md: -------------------------------------------------------------------------------- 1 | ``` 2 | cabal run -O1 bench-cats 3 | benchmarking main/Queue 100/right right 4 | time 344.2 μs (337.1 μs .. 362.0 μs) 5 | 0.974 R² (0.923 R² .. 1.000 R²) 6 | mean 346.8 μs (338.8 μs .. 375.4 μs) 7 | std dev 47.04 μs (4.662 μs .. 98.23 μs) 8 | variance introduced by outliers: 87% (severely inflated) 9 | 10 | benchmarking main/Queue 100/right left 11 | time 334.1 μs (333.3 μs .. 334.7 μs) 12 | 1.000 R² (1.000 R² .. 1.000 R²) 13 | mean 333.7 μs (333.1 μs .. 334.3 μs) 14 | std dev 2.083 μs (1.686 μs .. 2.609 μs) 15 | 16 | benchmarking main/Queue 100/left left 17 | time 336.6 μs (334.3 μs .. 340.4 μs) 18 | 0.997 R² (0.991 R² .. 1.000 R²) 19 | mean 339.0 μs (335.2 μs .. 353.2 μs) 20 | std dev 20.23 μs (6.119 μs .. 45.16 μs) 21 | variance introduced by outliers: 55% (severely inflated) 22 | 23 | benchmarking main/Queue 100/left right 24 | time 334.4 μs (333.9 μs .. 335.0 μs) 25 | 1.000 R² (1.000 R² .. 1.000 R²) 26 | mean 334.3 μs (333.6 μs .. 335.3 μs) 27 | std dev 2.840 μs (2.002 μs .. 4.592 μs) 28 | 29 | benchmarking main/Queue 100/alternate 30 | time 333.4 μs (332.9 μs .. 334.1 μs) 31 | 1.000 R² (1.000 R² .. 1.000 R²) 32 | mean 334.1 μs (333.5 μs .. 334.7 μs) 33 | std dev 1.989 μs (1.597 μs .. 2.655 μs) 34 | 35 | benchmarking main/ListTr 100/right right 36 | time 168.0 μs (167.7 μs .. 168.3 μs) 37 | 1.000 R² (1.000 R² .. 1.000 R²) 38 | mean 168.4 μs (168.1 μs .. 168.9 μs) 39 | std dev 1.328 μs (905.4 ns .. 2.041 μs) 40 | 41 | benchmarking main/ListTr 100/right left 42 | time 176.4 μs (173.7 μs .. 180.5 μs) 43 | 0.985 R² (0.966 R² .. 0.999 R²) 44 | mean 180.4 μs (174.5 μs .. 191.0 μs) 45 | std dev 26.56 μs (11.94 μs .. 40.58 μs) 46 | variance introduced by outliers: 90% (severely inflated) 47 | 48 | benchmarking main/ListTr 100/left left 49 | time 181.4 μs (171.8 μs .. 200.9 μs) 50 | 0.965 R² (0.926 R² .. 1.000 R²) 51 | mean 174.4 μs (171.5 μs .. 188.0 μs) 52 | std dev 17.44 μs (1.898 μs .. 39.71 μs) 53 | variance introduced by outliers: 80% (severely inflated) 54 | 55 | benchmarking main/ListTr 100/left right 56 | time 171.7 μs (170.3 μs .. 173.4 μs) 57 | 0.999 R² (0.999 R² .. 0.999 R²) 58 | mean 175.3 μs (173.9 μs .. 177.5 μs) 59 | std dev 5.737 μs (3.819 μs .. 10.35 μs) 60 | variance introduced by outliers: 30% (moderately inflated) 61 | 62 | benchmarking main/ListTr 100/alternate 63 | time 172.2 μs (169.5 μs .. 174.3 μs) 64 | 0.999 R² (0.999 R² .. 1.000 R²) 65 | mean 170.3 μs (169.6 μs .. 171.4 μs) 66 | std dev 2.847 μs (2.192 μs .. 3.745 μs) 67 | 68 | benchmarking main/C 100/right right 69 | time 741.9 μs (720.1 μs .. 769.8 μs) 70 | 0.996 R² (0.993 R² .. 0.999 R²) 71 | mean 738.5 μs (733.4 μs .. 746.4 μs) 72 | std dev 21.90 μs (14.74 μs .. 36.25 μs) 73 | variance introduced by outliers: 20% (moderately inflated) 74 | 75 | benchmarking main/C 100/right left 76 | time 671.2 μs (655.1 μs .. 693.1 μs) 77 | 0.974 R² (0.924 R² .. 0.999 R²) 78 | mean 681.5 μs (658.5 μs .. 777.3 μs) 79 | std dev 127.4 μs (26.16 μs .. 280.5 μs) 80 | variance introduced by outliers: 92% (severely inflated) 81 | 82 | benchmarking main/C 100/left left 83 | time 802.2 μs (784.7 μs .. 824.5 μs) 84 | 0.996 R² (0.996 R² .. 0.998 R²) 85 | mean 795.6 μs (787.1 μs .. 805.5 μs) 86 | std dev 30.72 μs (26.91 μs .. 35.57 μs) 87 | variance introduced by outliers: 29% (moderately inflated) 88 | 89 | benchmarking main/C 100/left right 90 | time 657.8 μs (650.4 μs .. 668.8 μs) 91 | 0.998 R² (0.997 R² .. 0.999 R²) 92 | mean 656.8 μs (649.6 μs .. 665.1 μs) 93 | std dev 26.63 μs (20.92 μs .. 35.68 μs) 94 | variance introduced by outliers: 33% (moderately inflated) 95 | 96 | benchmarking main/C 100/alternate 97 | time 1.065 ms (1.053 ms .. 1.082 ms) 98 | 0.997 R² (0.994 R² .. 0.999 R²) 99 | mean 1.074 ms (1.061 ms .. 1.093 ms) 100 | std dev 53.90 μs (39.80 μs .. 70.25 μs) 101 | variance introduced by outliers: 39% (moderately inflated) 102 | 103 | benchmarking main/Queue 250/right right 104 | time 3.203 ms (2.938 ms .. 3.591 ms) 105 | 0.966 R² (0.942 R² .. 0.998 R²) 106 | mean 2.963 ms (2.915 ms .. 3.067 ms) 107 | std dev 226.0 μs (94.89 μs .. 422.7 μs) 108 | variance introduced by outliers: 52% (severely inflated) 109 | 110 | benchmarking main/ListTr 250/right right 111 | time 3.265 ms (3.231 ms .. 3.295 ms) 112 | 0.999 R² (0.999 R² .. 1.000 R²) 113 | mean 3.261 ms (3.239 ms .. 3.284 ms) 114 | std dev 71.15 μs (57.97 μs .. 86.47 μs) 115 | 116 | benchmarking main/Queue 500/right right 117 | time 11.72 ms (11.47 ms .. 11.94 ms) 118 | 0.997 R² (0.996 R² .. 0.999 R²) 119 | mean 11.95 ms (11.79 ms .. 12.20 ms) 120 | std dev 521.0 μs (333.3 μs .. 799.6 μs) 121 | variance introduced by outliers: 17% (moderately inflated) 122 | 123 | benchmarking main/ListTr 500/right right 124 | time 17.55 ms (15.86 ms .. 18.15 ms) 125 | 0.956 R² (0.839 R² .. 0.999 R²) 126 | mean 18.91 ms (18.14 ms .. 22.44 ms) 127 | std dev 3.166 ms (347.5 μs .. 6.963 ms) 128 | variance introduced by outliers: 71% (severely inflated) 129 | ``` 130 | -------------------------------------------------------------------------------- /bench/report-O2.md: -------------------------------------------------------------------------------- 1 | ``` 2 | cabal run -O2 bench-cats 3 | benchmarking main/Queue 100/right right 4 | time 341.9 μs (341.2 μs .. 342.8 μs) 5 | 1.000 R² (1.000 R² .. 1.000 R²) 6 | mean 340.9 μs (340.0 μs .. 341.9 μs) 7 | std dev 3.115 μs (2.201 μs .. 4.603 μs) 8 | 9 | benchmarking main/Queue 100/right left 10 | time 342.2 μs (341.6 μs .. 342.8 μs) 11 | 1.000 R² (1.000 R² .. 1.000 R²) 12 | mean 341.5 μs (340.9 μs .. 342.2 μs) 13 | std dev 2.108 μs (1.700 μs .. 2.556 μs) 14 | 15 | benchmarking main/Queue 100/left left 16 | time 341.5 μs (341.1 μs .. 342.2 μs) 17 | 1.000 R² (1.000 R² .. 1.000 R²) 18 | mean 341.9 μs (341.2 μs .. 343.3 μs) 19 | std dev 3.117 μs (1.865 μs .. 5.348 μs) 20 | 21 | benchmarking main/Queue 100/left right 22 | time 344.0 μs (342.7 μs .. 345.8 μs) 23 | 1.000 R² (0.999 R² .. 1.000 R²) 24 | mean 344.5 μs (343.2 μs .. 346.5 μs) 25 | std dev 5.442 μs (4.365 μs .. 7.546 μs) 26 | 27 | benchmarking main/Queue 100/alternate 28 | time 359.1 μs (343.2 μs .. 378.1 μs) 29 | 0.989 R² (0.979 R² .. 0.999 R²) 30 | mean 347.1 μs (343.3 μs .. 357.3 μs) 31 | std dev 19.80 μs (10.27 μs .. 35.11 μs) 32 | variance introduced by outliers: 53% (severely inflated) 33 | 34 | benchmarking main/ListTr 100/right right 35 | time 175.0 μs (174.3 μs .. 176.0 μs) 36 | 0.999 R² (0.999 R² .. 1.000 R²) 37 | mean 175.8 μs (174.8 μs .. 178.3 μs) 38 | std dev 5.004 μs (2.051 μs .. 9.617 μs) 39 | variance introduced by outliers: 24% (moderately inflated) 40 | 41 | benchmarking main/ListTr 100/right left 42 | time 175.2 μs (174.2 μs .. 176.4 μs) 43 | 1.000 R² (1.000 R² .. 1.000 R²) 44 | mean 175.3 μs (174.6 μs .. 176.2 μs) 45 | std dev 2.866 μs (2.014 μs .. 4.405 μs) 46 | 47 | benchmarking main/ListTr 100/left left 48 | time 178.8 μs (175.7 μs .. 182.2 μs) 49 | 0.998 R² (0.998 R² .. 1.000 R²) 50 | mean 177.0 μs (175.6 μs .. 179.9 μs) 51 | std dev 6.350 μs (3.620 μs .. 11.78 μs) 52 | variance introduced by outliers: 33% (moderately inflated) 53 | 54 | benchmarking main/ListTr 100/left right 55 | time 174.2 μs (173.3 μs .. 175.6 μs) 56 | 0.999 R² (0.998 R² .. 0.999 R²) 57 | mean 180.9 μs (178.4 μs .. 184.9 μs) 58 | std dev 10.83 μs (7.423 μs .. 16.29 μs) 59 | variance introduced by outliers: 59% (severely inflated) 60 | 61 | benchmarking main/ListTr 100/alternate 62 | time 173.9 μs (173.0 μs .. 175.0 μs) 63 | 1.000 R² (1.000 R² .. 1.000 R²) 64 | mean 173.5 μs (173.0 μs .. 174.1 μs) 65 | std dev 1.951 μs (1.514 μs .. 2.633 μs) 66 | 67 | benchmarking main/C 100/right right 68 | time 798.5 μs (792.7 μs .. 803.5 μs) 69 | 1.000 R² (0.999 R² .. 1.000 R²) 70 | mean 797.5 μs (793.5 μs .. 800.9 μs) 71 | std dev 11.98 μs (9.948 μs .. 15.01 μs) 72 | 73 | benchmarking main/C 100/right left 74 | time 679.3 μs (670.8 μs .. 691.7 μs) 75 | 0.998 R² (0.997 R² .. 0.998 R²) 76 | mean 686.6 μs (678.4 μs .. 695.5 μs) 77 | std dev 27.59 μs (25.17 μs .. 30.52 μs) 78 | variance introduced by outliers: 32% (moderately inflated) 79 | 80 | benchmarking main/C 100/left left 81 | time 780.6 μs (776.9 μs .. 783.9 μs) 82 | 1.000 R² (1.000 R² .. 1.000 R²) 83 | mean 775.6 μs (772.1 μs .. 778.7 μs) 84 | std dev 10.92 μs (8.476 μs .. 15.08 μs) 85 | 86 | benchmarking main/C 100/left right 87 | time 601.6 μs (598.7 μs .. 604.4 μs) 88 | 1.000 R² (0.999 R² .. 1.000 R²) 89 | mean 607.9 μs (602.8 μs .. 616.0 μs) 90 | std dev 20.49 μs (15.07 μs .. 26.09 μs) 91 | variance introduced by outliers: 25% (moderately inflated) 92 | 93 | benchmarking main/C 100/alternate 94 | time 1.045 ms (987.6 μs .. 1.161 ms) 95 | 0.940 R² (0.867 R² .. 0.999 R²) 96 | mean 1.016 ms (986.8 μs .. 1.107 ms) 97 | std dev 152.4 μs (57.42 μs .. 296.9 μs) 98 | variance introduced by outliers: 86% (severely inflated) 99 | 100 | benchmarking main/Queue 250/right right 101 | time 2.733 ms (2.700 ms .. 2.764 ms) 102 | 0.999 R² (0.999 R² .. 1.000 R²) 103 | mean 2.694 ms (2.676 ms .. 2.710 ms) 104 | std dev 56.66 μs (45.91 μs .. 76.23 μs) 105 | 106 | benchmarking main/ListTr 250/right right 107 | time 3.356 ms (3.175 ms .. 3.551 ms) 108 | 0.979 R² (0.968 R² .. 0.989 R²) 109 | mean 3.425 ms (3.315 ms .. 3.587 ms) 110 | std dev 422.6 μs (296.3 μs .. 610.7 μs) 111 | variance introduced by outliers: 74% (severely inflated) 112 | 113 | benchmarking main/Queue 500/right right 114 | time 11.27 ms (10.84 ms .. 11.78 ms) 115 | 0.985 R² (0.973 R² .. 0.993 R²) 116 | mean 12.36 ms (11.94 ms .. 12.99 ms) 117 | std dev 1.344 ms (995.0 μs .. 1.928 ms) 118 | variance introduced by outliers: 56% (severely inflated) 119 | 120 | benchmarking main/ListTr 500/right right 121 | time 18.27 ms (17.13 ms .. 19.35 ms) 122 | 0.986 R² (0.975 R² .. 0.998 R²) 123 | mean 18.14 ms (17.70 ms .. 18.98 ms) 124 | std dev 1.466 ms (866.9 μs .. 2.203 ms) 125 | variance introduced by outliers: 35% (moderately inflated) 126 | ``` 127 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | index-state: 2024-09-01T10:40:50Z 2 | 3 | packages: . 4 | examples 5 | -------------------------------------------------------------------------------- /examples/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for examples 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /examples/LICENSE: -------------------------------------------------------------------------------- 1 | Mozilla Public License Version 2.0 2 | ================================== 3 | 4 | 1. Definitions 5 | -------------- 6 | 7 | 1.1. "Contributor" 8 | means each individual or legal entity that creates, contributes to 9 | the creation of, or owns Covered Software. 10 | 11 | 1.2. "Contributor Version" 12 | means the combination of the Contributions of others (if any) used 13 | by a Contributor and that particular Contributor's Contribution. 14 | 15 | 1.3. "Contribution" 16 | means Covered Software of a particular Contributor. 17 | 18 | 1.4. "Covered Software" 19 | means Source Code Form to which the initial Contributor has attached 20 | the notice in Exhibit A, the Executable Form of such Source Code 21 | Form, and Modifications of such Source Code Form, in each case 22 | including portions thereof. 23 | 24 | 1.5. "Incompatible With Secondary Licenses" 25 | means 26 | 27 | (a) that the initial Contributor has attached the notice described 28 | in Exhibit B to the Covered Software; or 29 | 30 | (b) that the Covered Software was made available under the terms of 31 | version 1.1 or earlier of the License, but not also under the 32 | terms of a Secondary License. 33 | 34 | 1.6. "Executable Form" 35 | means any form of the work other than Source Code Form. 36 | 37 | 1.7. "Larger Work" 38 | means a work that combines Covered Software with other material, in 39 | a separate file or files, that is not Covered Software. 40 | 41 | 1.8. "License" 42 | means this document. 43 | 44 | 1.9. "Licensable" 45 | means having the right to grant, to the maximum extent possible, 46 | whether at the time of the initial grant or subsequently, any and 47 | all of the rights conveyed by this License. 48 | 49 | 1.10. "Modifications" 50 | means any of the following: 51 | 52 | (a) any file in Source Code Form that results from an addition to, 53 | deletion from, or modification of the contents of Covered 54 | Software; or 55 | 56 | (b) any new file in Source Code Form that contains any Covered 57 | Software. 58 | 59 | 1.11. "Patent Claims" of a Contributor 60 | means any patent claim(s), including without limitation, method, 61 | process, and apparatus claims, in any patent Licensable by such 62 | Contributor that would be infringed, but for the grant of the 63 | License, by the making, using, selling, offering for sale, having 64 | made, import, or transfer of either its Contributions or its 65 | Contributor Version. 66 | 67 | 1.12. "Secondary License" 68 | means either the GNU General Public License, Version 2.0, the GNU 69 | Lesser General Public License, Version 2.1, the GNU Affero General 70 | Public License, Version 3.0, or any later versions of those 71 | licenses. 72 | 73 | 1.13. "Source Code Form" 74 | means the form of the work preferred for making modifications. 75 | 76 | 1.14. "You" (or "Your") 77 | means an individual or a legal entity exercising rights under this 78 | License. For legal entities, "You" includes any entity that 79 | controls, is controlled by, or is under common control with You. For 80 | purposes of this definition, "control" means (a) the power, direct 81 | or indirect, to cause the direction or management of such entity, 82 | whether by contract or otherwise, or (b) ownership of more than 83 | fifty percent (50%) of the outstanding shares or beneficial 84 | ownership of such entity. 85 | 86 | 2. License Grants and Conditions 87 | -------------------------------- 88 | 89 | 2.1. Grants 90 | 91 | Each Contributor hereby grants You a world-wide, royalty-free, 92 | non-exclusive license: 93 | 94 | (a) under intellectual property rights (other than patent or trademark) 95 | Licensable by such Contributor to use, reproduce, make available, 96 | modify, display, perform, distribute, and otherwise exploit its 97 | Contributions, either on an unmodified basis, with Modifications, or 98 | as part of a Larger Work; and 99 | 100 | (b) under Patent Claims of such Contributor to make, use, sell, offer 101 | for sale, have made, import, and otherwise transfer either its 102 | Contributions or its Contributor Version. 103 | 104 | 2.2. Effective Date 105 | 106 | The licenses granted in Section 2.1 with respect to any Contribution 107 | become effective for each Contribution on the date the Contributor first 108 | distributes such Contribution. 109 | 110 | 2.3. Limitations on Grant Scope 111 | 112 | The licenses granted in this Section 2 are the only rights granted under 113 | this License. No additional rights or licenses will be implied from the 114 | distribution or licensing of Covered Software under this License. 115 | Notwithstanding Section 2.1(b) above, no patent license is granted by a 116 | Contributor: 117 | 118 | (a) for any code that a Contributor has removed from Covered Software; 119 | or 120 | 121 | (b) for infringements caused by: (i) Your and any other third party's 122 | modifications of Covered Software, or (ii) the combination of its 123 | Contributions with other software (except as part of its Contributor 124 | Version); or 125 | 126 | (c) under Patent Claims infringed by Covered Software in the absence of 127 | its Contributions. 128 | 129 | This License does not grant any rights in the trademarks, service marks, 130 | or logos of any Contributor (except as may be necessary to comply with 131 | the notice requirements in Section 3.4). 132 | 133 | 2.4. Subsequent Licenses 134 | 135 | No Contributor makes additional grants as a result of Your choice to 136 | distribute the Covered Software under a subsequent version of this 137 | License (see Section 10.2) or under the terms of a Secondary License (if 138 | permitted under the terms of Section 3.3). 139 | 140 | 2.5. Representation 141 | 142 | Each Contributor represents that the Contributor believes its 143 | Contributions are its original creation(s) or it has sufficient rights 144 | to grant the rights to its Contributions conveyed by this License. 145 | 146 | 2.6. Fair Use 147 | 148 | This License is not intended to limit any rights You have under 149 | applicable copyright doctrines of fair use, fair dealing, or other 150 | equivalents. 151 | 152 | 2.7. Conditions 153 | 154 | Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted 155 | in Section 2.1. 156 | 157 | 3. Responsibilities 158 | ------------------- 159 | 160 | 3.1. Distribution of Source Form 161 | 162 | All distribution of Covered Software in Source Code Form, including any 163 | Modifications that You create or to which You contribute, must be under 164 | the terms of this License. You must inform recipients that the Source 165 | Code Form of the Covered Software is governed by the terms of this 166 | License, and how they can obtain a copy of this License. You may not 167 | attempt to alter or restrict the recipients' rights in the Source Code 168 | Form. 169 | 170 | 3.2. Distribution of Executable Form 171 | 172 | If You distribute Covered Software in Executable Form then: 173 | 174 | (a) such Covered Software must also be made available in Source Code 175 | Form, as described in Section 3.1, and You must inform recipients of 176 | the Executable Form how they can obtain a copy of such Source Code 177 | Form by reasonable means in a timely manner, at a charge no more 178 | than the cost of distribution to the recipient; and 179 | 180 | (b) You may distribute such Executable Form under the terms of this 181 | License, or sublicense it under different terms, provided that the 182 | license for the Executable Form does not attempt to limit or alter 183 | the recipients' rights in the Source Code Form under this License. 184 | 185 | 3.3. Distribution of a Larger Work 186 | 187 | You may create and distribute a Larger Work under terms of Your choice, 188 | provided that You also comply with the requirements of this License for 189 | the Covered Software. If the Larger Work is a combination of Covered 190 | Software with a work governed by one or more Secondary Licenses, and the 191 | Covered Software is not Incompatible With Secondary Licenses, this 192 | License permits You to additionally distribute such Covered Software 193 | under the terms of such Secondary License(s), so that the recipient of 194 | the Larger Work may, at their option, further distribute the Covered 195 | Software under the terms of either this License or such Secondary 196 | License(s). 197 | 198 | 3.4. Notices 199 | 200 | You may not remove or alter the substance of any license notices 201 | (including copyright notices, patent notices, disclaimers of warranty, 202 | or limitations of liability) contained within the Source Code Form of 203 | the Covered Software, except that You may alter any license notices to 204 | the extent required to remedy known factual inaccuracies. 205 | 206 | 3.5. Application of Additional Terms 207 | 208 | You may choose to offer, and to charge a fee for, warranty, support, 209 | indemnity or liability obligations to one or more recipients of Covered 210 | Software. However, You may do so only on Your own behalf, and not on 211 | behalf of any Contributor. You must make it absolutely clear that any 212 | such warranty, support, indemnity, or liability obligation is offered by 213 | You alone, and You hereby agree to indemnify every Contributor for any 214 | liability incurred by such Contributor as a result of warranty, support, 215 | indemnity or liability terms You offer. You may include additional 216 | disclaimers of warranty and limitations of liability specific to any 217 | jurisdiction. 218 | 219 | 4. Inability to Comply Due to Statute or Regulation 220 | --------------------------------------------------- 221 | 222 | If it is impossible for You to comply with any of the terms of this 223 | License with respect to some or all of the Covered Software due to 224 | statute, judicial order, or regulation then You must: (a) comply with 225 | the terms of this License to the maximum extent possible; and (b) 226 | describe the limitations and the code they affect. Such description must 227 | be placed in a text file included with all distributions of the Covered 228 | Software under this License. Except to the extent prohibited by statute 229 | or regulation, such description must be sufficiently detailed for a 230 | recipient of ordinary skill to be able to understand it. 231 | 232 | 5. Termination 233 | -------------- 234 | 235 | 5.1. The rights granted under this License will terminate automatically 236 | if You fail to comply with any of its terms. However, if You become 237 | compliant, then the rights granted under this License from a particular 238 | Contributor are reinstated (a) provisionally, unless and until such 239 | Contributor explicitly and finally terminates Your grants, and (b) on an 240 | ongoing basis, if such Contributor fails to notify You of the 241 | non-compliance by some reasonable means prior to 60 days after You have 242 | come back into compliance. Moreover, Your grants from a particular 243 | Contributor are reinstated on an ongoing basis if such Contributor 244 | notifies You of the non-compliance by some reasonable means, this is the 245 | first time You have received notice of non-compliance with this License 246 | from such Contributor, and You become compliant prior to 30 days after 247 | Your receipt of the notice. 248 | 249 | 5.2. If You initiate litigation against any entity by asserting a patent 250 | infringement claim (excluding declaratory judgment actions, 251 | counter-claims, and cross-claims) alleging that a Contributor Version 252 | directly or indirectly infringes any patent, then the rights granted to 253 | You by any and all Contributors for the Covered Software under Section 254 | 2.1 of this License shall terminate. 255 | 256 | 5.3. In the event of termination under Sections 5.1 or 5.2 above, all 257 | end user license agreements (excluding distributors and resellers) which 258 | have been validly granted by You or Your distributors under this License 259 | prior to termination shall survive termination. 260 | 261 | ************************************************************************ 262 | * * 263 | * 6. Disclaimer of Warranty * 264 | * ------------------------- * 265 | * * 266 | * Covered Software is provided under this License on an "as is" * 267 | * basis, without warranty of any kind, either expressed, implied, or * 268 | * statutory, including, without limitation, warranties that the * 269 | * Covered Software is free of defects, merchantable, fit for a * 270 | * particular purpose or non-infringing. The entire risk as to the * 271 | * quality and performance of the Covered Software is with You. * 272 | * Should any Covered Software prove defective in any respect, You * 273 | * (not any Contributor) assume the cost of any necessary servicing, * 274 | * repair, or correction. This disclaimer of warranty constitutes an * 275 | * essential part of this License. No use of any Covered Software is * 276 | * authorized under this License except under this disclaimer. * 277 | * * 278 | ************************************************************************ 279 | 280 | ************************************************************************ 281 | * * 282 | * 7. Limitation of Liability * 283 | * -------------------------- * 284 | * * 285 | * Under no circumstances and under no legal theory, whether tort * 286 | * (including negligence), contract, or otherwise, shall any * 287 | * Contributor, or anyone who distributes Covered Software as * 288 | * permitted above, be liable to You for any direct, indirect, * 289 | * special, incidental, or consequential damages of any character * 290 | * including, without limitation, damages for lost profits, loss of * 291 | * goodwill, work stoppage, computer failure or malfunction, or any * 292 | * and all other commercial damages or losses, even if such party * 293 | * shall have been informed of the possibility of such damages. This * 294 | * limitation of liability shall not apply to liability for death or * 295 | * personal injury resulting from such party's negligence to the * 296 | * extent applicable law prohibits such limitation. Some * 297 | * jurisdictions do not allow the exclusion or limitation of * 298 | * incidental or consequential damages, so this exclusion and * 299 | * limitation may not apply to You. * 300 | * * 301 | ************************************************************************ 302 | 303 | 8. Litigation 304 | ------------- 305 | 306 | Any litigation relating to this License may be brought only in the 307 | courts of a jurisdiction where the defendant maintains its principal 308 | place of business and such litigation shall be governed by laws of that 309 | jurisdiction, without reference to its conflict-of-law provisions. 310 | Nothing in this Section shall prevent a party's ability to bring 311 | cross-claims or counter-claims. 312 | 313 | 9. Miscellaneous 314 | ---------------- 315 | 316 | This License represents the complete agreement concerning the subject 317 | matter hereof. If any provision of this License is held to be 318 | unenforceable, such provision shall be reformed only to the extent 319 | necessary to make it enforceable. Any law or regulation which provides 320 | that the language of a contract shall be construed against the drafter 321 | shall not be used to construe this License against a Contributor. 322 | 323 | 10. Versions of the License 324 | --------------------------- 325 | 326 | 10.1. New Versions 327 | 328 | Mozilla Foundation is the license steward. Except as provided in Section 329 | 10.3, no one other than the license steward has the right to modify or 330 | publish new versions of this License. Each version will be given a 331 | distinguishing version number. 332 | 333 | 10.2. Effect of New Versions 334 | 335 | You may distribute the Covered Software under the terms of the version 336 | of the License under which You originally received the Covered Software, 337 | or under the terms of any subsequent version published by the license 338 | steward. 339 | 340 | 10.3. Modified Versions 341 | 342 | If you create software not governed by this License, and you want to 343 | create a new license for such software, you may create and use a 344 | modified version of this License if you rename the license and remove 345 | any references to the name of the license steward (except to note that 346 | such modified license differs from this License). 347 | 348 | 10.4. Distributing Source Code Form that is Incompatible With Secondary 349 | Licenses 350 | 351 | If You choose to distribute Source Code Form that is Incompatible With 352 | Secondary Licenses under the terms of this version of the License, the 353 | notice described in Exhibit B of this License must be attached. 354 | 355 | Exhibit A - Source Code Form License Notice 356 | ------------------------------------------- 357 | 358 | This Source Code Form is subject to the terms of the Mozilla Public 359 | License, v. 2.0. If a copy of the MPL was not distributed with this 360 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 361 | 362 | If it is not possible or desirable to put the notice in a particular 363 | file, then You may include the notice in a location (such as a LICENSE 364 | file in a relevant directory) where a recipient would be likely to look 365 | for such a notice. 366 | 367 | You may add additional accurate notices of copyright ownership. 368 | 369 | Exhibit B - "Incompatible With Secondary Licenses" Notice 370 | --------------------------------------------------------- 371 | 372 | This Source Code Form is "Incompatible With Secondary Licenses", as 373 | defined by the Mozilla Public License, v. 2.0. 374 | -------------------------------------------------------------------------------- /examples/README.md: -------------------------------------------------------------------------------- 1 | Example State Machine using 'EffCat' 2 | 3 | The example state machine is inspired by 4 | `State Machines All The Way Down` by Edwin Brady, 2017 5 | https://www.youtube.com/watch?v=xq7ZuSRgCR4 6 | 7 | It allows to login, access a secret token and logout. 8 | The secret token can only be accessed upon successful login. The 9 | implementation type checks this requirement. 10 | 11 | Run quickcheck tests and an example program: 12 | ``` 13 | cabal run examples 14 | +++ OK, passed 100 tests. 15 | 16 | Provide a password: 17 | 123456 18 | Provide a password: 19 | password 20 | secret: Hello saylor! 21 | ``` 22 | -------------------------------------------------------------------------------- /examples/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/examples.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.0 2 | name: examples 3 | version: 0.1.0.0 4 | synopsis: free-category examples 5 | -- description: 6 | license: MPL-2.0 7 | license-file: LICENSE 8 | author: Marcin Szamotulski 9 | maintainer: profunctor@pm.me 10 | -- copyright: 11 | -- category: 12 | build-type: Simple 13 | extra-source-files: CHANGELOG.md 14 | 15 | executable login-state-machine 16 | main-is: LoginStateMachine.hs 17 | -- exposed-modules: 18 | -- other-modules: 19 | -- other-extensions: 20 | build-depends: base >=4.9 && <5 21 | , free-category >= 0.0.1.0 22 | , free-algebras >= 0.0.7.0 23 | , QuickCheck 24 | hs-source-dirs: src 25 | default-language: Haskell2010 26 | ghc-options: -Wall 27 | -fwarn-incomplete-record-updates 28 | -fwarn-incomplete-uni-patterns 29 | -fwarn-redundant-constraints 30 | -fwarn-deprecations 31 | -main-is LoginStateMachine 32 | -------------------------------------------------------------------------------- /examples/src/LoginStateMachine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TupleSections #-} 10 | module LoginStateMachine where 11 | 12 | import Prelude hiding (id, (.)) 13 | 14 | import Control.Arrow (Kleisli (..)) 15 | import Control.Category (Category (..)) 16 | import Control.Monad (void) 17 | -- import Control.Algebra.Free2 18 | import Numeric.Natural (Natural) 19 | import Data.Functor (($>)) 20 | import Data.Functor.Identity (Identity (..)) 21 | import Data.List.NonEmpty (NonEmpty (..)) 22 | import qualified Data.List.NonEmpty as NE 23 | 24 | import Test.QuickCheck 25 | 26 | import Control.Category.Free (ListTr) 27 | 28 | -- Import classes and combintators used in this example 29 | import Control.Category.FreeEffect 30 | 31 | {------------------------------------------------------------------------------- 32 | -- Example State Machine, inspired by: 33 | -- `State Machines All The Way Down` by Edwin Brady, 2017 34 | -- https://www.youtube.com/watch?v=xq7ZuSRgCR4 35 | -------------------------------------------------------------------------------} 36 | 37 | data LoginResult = Success | LoginError 38 | 39 | -- | Type level representation of the states. 40 | -- 41 | data StateType where 42 | LoggedInType :: StateType 43 | LoggedOutType :: StateType 44 | 45 | data SStateType (a :: StateType) where 46 | SLoggedIn :: SStateType 'LoggedInType 47 | SLoggedOut :: SStateType 'LoggedOutType 48 | 49 | -- | Term level representation of the states. 50 | -- @'LoggedOut'@ let one carry out a value. 51 | -- 52 | data State a (st :: StateType) where 53 | LoggedIn :: State a 'LoggedInType 54 | LoggedOut :: Maybe a -> State a 'LoggedOutType 55 | 56 | runLoggedOut :: State a 'LoggedOutType -> Maybe a 57 | runLoggedOut (LoggedOut a) = a 58 | 59 | 60 | -- | Graph of transitions in the state machine. In abstract representation the 61 | -- states do not show up, the only way to record some data is to add it to the 62 | -- transition. Thus @'Logout'@ can carry data. When interpreted in some 63 | -- category (e.g. @'Kleisli' m@) then the data will be available on 64 | -- @'LoggedOut{} :: 'State' a st@. 65 | -- 66 | data Tr a (from :: StateType) (to :: StateType) where 67 | Login 68 | :: SStateType to 69 | -> Tr a 'LoggedOutType to 70 | 71 | Logout 72 | :: Maybe a 73 | -> Tr a 'LoggedInType 'LoggedOutType 74 | 75 | Access 76 | :: Tr a 'LoggedInType 'LoggedInType 77 | 78 | login :: Monad m 79 | => SStateType st 80 | -> EffCat m (ListTr (Tr a)) 'LoggedOutType st 81 | login = liftEffect . Login 82 | 83 | logout :: Monad m 84 | => Maybe a 85 | -> EffCat m (ListTr (Tr a)) 'LoggedInType 'LoggedOutType 86 | logout = liftEffect . Logout 87 | 88 | access :: Monad m 89 | => EffCat m (ListTr (Tr a)) 'LoggedInType 'LoggedInType 90 | access = liftEffect Access 91 | 92 | -- 93 | -- Public API 94 | -- 95 | 96 | type Username = String 97 | 98 | -- * Data representation of the state machine. 99 | 100 | data HandleLogin m authtoken a = HandleLogin { 101 | handleLogin 102 | :: m (Either (HandleLogin m authtoken a) (HandleAccess m a)), 103 | -- ^ either failure with a login continuation or handle access to the 104 | -- secret data 105 | handleAccessDenied 106 | :: m () 107 | -- ^ handle access denied 108 | } 109 | 110 | data HandleAccess m a where 111 | AccessHandler 112 | :: m a -- access secret 113 | -> (a -> m (HandleAccess m a)) -- handle secret 114 | -> HandleAccess m a 115 | LogoutHandler :: HandleAccess m a 116 | 117 | handleLoginIO 118 | :: String 119 | -> HandleLogin IO String String 120 | handleLoginIO passwd = HandleLogin 121 | { handleLogin 122 | , handleAccessDenied 123 | } 124 | where 125 | handleLogin = do 126 | passwd' <- putStrLn "Provide a password:" >> getLine 127 | if passwd' == passwd 128 | then return $ Right handleAccess 129 | else return $ Left $ handleLoginIO passwd 130 | 131 | handleAccess = AccessHandler (pure "Hello saylor!") $ 132 | \s -> do 133 | putStrLn ("secret: " ++ s) 134 | return LogoutHandler 135 | 136 | handleAccessDenied = putStrLn "AccessDenied" 137 | 138 | -- pure @'HandleLogin'@ useful for testing @'accessSecret'@ 139 | handleLoginPure 140 | :: NonEmpty String -- ^ passwords to try (cyclicly, ad infinitum) 141 | -> String -- ^ authtoken 142 | -> String -- ^ secret 143 | -> HandleLogin Identity String String 144 | handleLoginPure passwds passwd secret = HandleLogin 145 | { handleLogin = handleLogin passwds 146 | , handleAccessDenied = pure () 147 | } 148 | where 149 | handleLogin (passwd' :| rest) = 150 | if passwd' == passwd 151 | then return $ Right handleAccess 152 | else case rest of 153 | [] -> return $ Left $ handleLoginPure passwds passwd secret 154 | _ -> return $ Left $ handleLoginPure (NE.fromList rest) passwd secret 155 | 156 | handleAccess = AccessHandler (pure secret) $ \_ -> return LogoutHandler 157 | 158 | -- 159 | -- Abstract State Machine Description 160 | -- 161 | 162 | -- | Abstract access function 163 | -- 164 | accessSecret 165 | :: forall m a . Monad m 166 | => Natural 167 | -- ^ how many times one can try to login; this could be implemented inside 168 | -- @'HandleLogin'@ (with a small modifications) but this way we are able to 169 | -- test it with a pure @'HandleLogin'@ (see @'handleLoginPure'@). 170 | -> HandleLogin m String a 171 | -> EffCat m (ListTr (Tr a)) 'LoggedOutType 'LoggedOutType 172 | accessSecret 0 HandleLogin{handleAccessDenied} 173 | = effect $ handleAccessDenied $> id 174 | 175 | accessSecret n HandleLogin{handleLogin} 176 | = effect $ do 177 | st <- handleLogin 178 | case st of 179 | -- login success 180 | Right accessHandler -> return $ handle accessHandler Nothing . login SLoggedIn 181 | -- login failure 182 | Left handler' -> return $ accessSecret (pred n) handler' 183 | where 184 | handle :: HandleAccess m a 185 | -> Maybe a 186 | -> EffCat m (ListTr (Tr a)) 'LoggedInType 'LoggedOutType 187 | handle LogoutHandler ma = logout ma 188 | handle (AccessHandler accessHandler dataHandler) _ = effect $ do 189 | a <- accessHandler 190 | accessHandler' <- dataHandler a 191 | return $ handle accessHandler' (Just a) 192 | 193 | -- 194 | -- Run Abstract State Machine 195 | -- 196 | 197 | newtype KleisliS m a (from :: StateType) (to :: StateType) 198 | = KleisliS { runKleisliS :: Kleisli m (State a from) (State a to) } 199 | 200 | instance Monad m => Category (KleisliS m a) where 201 | id = KleisliS id 202 | KleisliS f . KleisliS g = KleisliS (f . g) 203 | 204 | instance Monad m => EffectCategory (KleisliS m a) m where 205 | effect mf = KleisliS $ Kleisli $ \a -> mg >>= \g -> g a 206 | where 207 | mg = runKleisli . runKleisliS <$> mf 208 | 209 | -- | Get data following the protocol defined by the state machine. 210 | -- 211 | -- Note: in GHC-8.6.1 we'd need @'MonadFail'@ which prevents from running this in 212 | -- @'Identity'@ monad. To avoid this we use the @'runLoggedOut'@ function. 213 | getData 214 | :: forall m a . Monad m 215 | => (forall x y. Tr a x y -> KleisliS m a x y) 216 | -> Natural 217 | -> HandleLogin m String a 218 | -> m (Maybe a) 219 | getData nat n handleLogin = case foldNatEffCat nat (accessSecret n handleLogin) of 220 | KleisliS (Kleisli fn) -> do 221 | ma <- runLoggedOut <$> fn (LoggedOut Nothing) 222 | return ma 223 | 224 | -- * Interpreters 225 | -- To write an interpreter it is enough to supply a natural transformation from 226 | -- @'Tr' a from to@ to @'Kleisli' m@ for some monad @m@. 227 | 228 | -- | A pure natural transformation from @'Tr'@ to @'Kleisli' m@ for some 229 | -- @'Monad' m@. Note, that even though @'Kleisli'@ category seems redundant 230 | -- here, as we don't use the monad in the transformation, we need 231 | -- a transformation into a category that satisfies the @'Lifing'@ constraint. 232 | -- This is because we will need the monad when @'foldNatLift'@ will walk over the 233 | -- constructors of the '@FreeLifting'@ category. 234 | -- 235 | natPure :: forall m a from to. 236 | Monad m 237 | => Tr a from to 238 | -> KleisliS m a from to 239 | natPure = KleisliS . liftKleisli . nat 240 | where 241 | -- a natural trasformation to @'->'@ 242 | nat :: Tr a from to 243 | -> (State a from -> State a to) 244 | nat (Login SLoggedIn) = \_ -> LoggedIn 245 | nat (Login SLoggedOut) = \_ -> LoggedOut Nothing 246 | nat (Logout ma) = \_ -> LoggedOut ma 247 | nat Access = \_ -> LoggedIn 248 | 249 | -- | QuickCheck property test using 'Identity' monad (e.g. pure monad) 250 | -- 251 | prop_getData 252 | :: NonEmptyList String 253 | -> String 254 | -> String 255 | -> Positive Int 256 | -> Property 257 | prop_getData (NonEmpty passwds) passwd secret (Positive n) = 258 | let res = runIdentity $ getData natPure (fromIntegral n) (handleLoginPure (NE.fromList passwds) passwd secret) 259 | in if elem passwd (take n passwds) 260 | then res === Just secret 261 | else res === Nothing 262 | 263 | -- | A trivial program, which extracts a trivial secret. 264 | main :: IO () 265 | main = do 266 | putStrLn "" 267 | quickCheck prop_getData 268 | putStrLn "" 269 | void $ getData natPure 3 (handleLoginIO "password") 270 | -------------------------------------------------------------------------------- /free-category.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: free-category 3 | version: 0.0.4.5 4 | synopsis: efficient data types for free categories and arrows 5 | description: 6 | This package provides various data types for free categories, type 7 | aligned queues, arrows and type classes which allow to write abstract 8 | categories with side effects (Kleisli like categories). These are useful 9 | for encoding type safe state machines. Free arrows are also provided. 10 | category: Algebra, Control, Monads, Category 11 | homepage: https://github.com/coot/free-category#readme 12 | bug-reports: https://github.com/coot/free-category/issues 13 | author: Marcin Szamotulski 14 | maintainer: coot@coot.me 15 | copyright: (c) 2018-2024 Marcin Szamotulski 16 | license: MPL-2.0 17 | license-file: LICENSE 18 | build-type: Simple 19 | extra-source-files: 20 | ChangeLog.md 21 | README.md 22 | bench/report-O0.md 23 | bench/report-O1.md 24 | bench/report-O2.md 25 | stability: experimental 26 | tested-with: GHC == { 8.10, 9.0, 9.2, 9.4, 9.6, 9.8, 9.10 } 27 | 28 | source-repository head 29 | type: git 30 | location: https://github.com/coot/free-category 31 | 32 | library 33 | exposed-modules: 34 | Control.Arrow.Free 35 | Control.Category.Free 36 | Control.Category.Free.Internal 37 | Control.Category.FreeEffect 38 | other-modules: 39 | Paths_free_category 40 | autogen-modules: 41 | Paths_free_category 42 | hs-source-dirs: 43 | src 44 | build-depends: 45 | base >= 4.9 && < 5.0 46 | , free-algebras ^>= 0.1.1.0 || ^>= 0.1.2 47 | , profunctors ^>= 5.6 48 | ghc-options: 49 | -Wall 50 | -fwarn-incomplete-record-updates 51 | -fwarn-incomplete-uni-patterns 52 | -fwarn-redundant-constraints 53 | -fwarn-deprecations 54 | default-language: Haskell2010 55 | 56 | test-suite test-cats 57 | type: 58 | exitcode-stdio-1.0 59 | hs-source-dirs: 60 | test 61 | main-is: 62 | Main.hs 63 | other-modules: 64 | Test.Cat 65 | Test.Queue 66 | build-depends: 67 | base 68 | , QuickCheck 69 | , tasty-quickcheck 70 | , tasty 71 | , free-algebras 72 | 73 | , free-category 74 | ghc-options: 75 | -Wall 76 | -fwarn-incomplete-record-updates 77 | -fwarn-incomplete-uni-patterns 78 | -fno-ignore-asserts 79 | -fwarn-deprecations 80 | default-language: Haskell2010 81 | 82 | benchmark bench-cats 83 | hs-source-dirs: 84 | bench 85 | main-is: 86 | Main.hs 87 | type: 88 | exitcode-stdio-1.0 89 | build-depends: 90 | base 91 | , free-category 92 | , criterion 93 | ghc-options: 94 | -rtsopts 95 | default-language: Haskell2010 96 | -------------------------------------------------------------------------------- /src/Control/Arrow/Free.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE InstanceSigs #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | {-# OPTIONS_HADDOCK show-extensions #-} 11 | 12 | module Control.Arrow.Free 13 | ( -- * Free arrow 14 | Arr (..) 15 | , arrArr 16 | , liftArr 17 | , mapArr 18 | , foldArr 19 | 20 | -- * Free arrow (CPS style) 21 | , A (..) 22 | , fromA 23 | , toA 24 | -- * Free interface re-exports 25 | , FreeAlgebra2 (..) 26 | , wrapFree2 27 | , foldFree2 28 | , hoistFree2 29 | , joinFree2 30 | , bindFree2 31 | -- * Free 'ArrowChoice' 32 | , Choice (..) 33 | , liftArrChoice 34 | , foldArrChoice 35 | ) where 36 | 37 | import Prelude hiding (id, (.)) 38 | import Control.Arrow (Arrow (..), ArrowChoice (..), (>>>), (^>>), (^<<)) 39 | import Control.Category (Category (..)) 40 | import Data.Profunctor (Profunctor (..)) 41 | 42 | import Control.Algebra.Free2 43 | ( AlgebraType0 44 | , AlgebraType 45 | , FreeAlgebra2 (..) 46 | , Proof (..) 47 | , wrapFree2 48 | , foldFree2 49 | , hoistFree2 50 | , hoistFreeH2 51 | , joinFree2 52 | , bindFree2 53 | ) 54 | import Control.Category.Free.Internal 55 | 56 | data Arr f a b where 57 | Id :: Arr f a a 58 | Cons :: f b c -> Queue (Arr f) a b -> Arr f a c 59 | Arr :: (b -> c) -> Arr f a b -> Arr f a c 60 | Prod :: Arr f a b -> Arr f a c -> Arr f a (b, c) 61 | 62 | arrArr :: (b -> c) -> Arr f b c 63 | arrArr bc = Arr bc Id 64 | 65 | liftArr :: f a b 66 | -> Arr f a b 67 | liftArr f = Cons f nilQ 68 | 69 | mapArr :: f b c 70 | -> Arr f a b 71 | -> Arr f a c 72 | mapArr bc ac = Cons bc nilQ . ac 73 | 74 | foldArr :: forall f arr a b. 75 | Arrow arr 76 | => (forall x y. f x y -> arr x y) 77 | -> Arr f a b 78 | -> arr a b 79 | foldArr _ Id = id 80 | foldArr fun (Cons bc ab) = fun bc . foldNatQ (foldNatFree2 fun) ab 81 | foldArr fun (Arr f g) = arr f . foldNatFree2 fun g 82 | foldArr fun (Prod f g) = foldNatFree2 fun f &&& foldNatFree2 fun g 83 | 84 | instance Category (Arr f) where 85 | id = Id 86 | Id . f = f 87 | f . Id = f 88 | (Cons f g) . h = Cons f (g `snocQ` h) 89 | (Arr f g) . h = Arr f (g . h) 90 | (Prod f g) . h = Prod (f . h) (g . h) 91 | 92 | instance Semigroup (Arr f o o) where 93 | f <> g = f . g 94 | 95 | instance Monoid (Arr f o o) where 96 | mempty = Id 97 | 98 | instance Arrow (Arr f) where 99 | arr = arrArr 100 | first bc = Prod (bc . arr fst) (arr snd) 101 | second bc = Prod (arr fst) (bc . arr snd) 102 | ab *** xy = Prod (ab . arr fst) (xy . arr snd) 103 | (&&&) = Prod 104 | 105 | instance Profunctor (Arr f) where 106 | lmap = (^>>) 107 | {-# INLINE lmap #-} 108 | rmap = Arr 109 | {-# INLINE rmap #-} 110 | 111 | type instance AlgebraType0 Arr f = () 112 | type instance AlgebraType Arr c = Arrow c 113 | 114 | instance FreeAlgebra2 Arr where 115 | liftFree2 = \fab -> Cons fab nilQ 116 | {-# INLINE liftFree2 #-} 117 | 118 | foldNatFree2 = foldArr 119 | {-# INLINE foldNatFree2 #-} 120 | 121 | codom2 = Proof 122 | forget2 = Proof 123 | 124 | -- 125 | -- Free arrows using CSP style 126 | -- 127 | 128 | -- | Free arrow using CPS style. 129 | -- 130 | newtype A f a b 131 | = A { runA :: forall r. Arrow r 132 | => (forall x y. f x y -> r x y) 133 | -> r a b 134 | } 135 | 136 | -- | Isomorphism from @'Arr'@ to @'A'@, which is a specialisation of 137 | -- @'hoistFreeH2'@. 138 | -- 139 | toA :: Arr f a b -> A f a b 140 | toA = hoistFreeH2 141 | {-# INLINE toA #-} 142 | 143 | -- | Inverse of @'fromA'@, which also is a specialisation of @'hoistFreeH2'@. 144 | -- 145 | fromA :: A f a b -> Arr f a b 146 | fromA = hoistFreeH2 147 | {-# INLINE fromA #-} 148 | 149 | instance Category (A f) where 150 | id = A (\_ -> id) 151 | A f . A g = A $ \k -> f k . g k 152 | 153 | instance Semigroup (A f o o) where 154 | f <> g = f . g 155 | 156 | instance Monoid (A f o o) where 157 | mempty = id 158 | 159 | instance Arrow (A f) where 160 | arr f = A (\_ -> (arr f)) 161 | A f *** A g = A $ \k -> f k *** g k 162 | first (A f) = A $ \k -> first (f k) 163 | second (A f) = A $ \k -> second (f k) 164 | 165 | instance Profunctor (A f) where 166 | lmap f (A g) = A (\k -> f ^>> g k) 167 | {-# INLINE lmap #-} 168 | rmap f (A g) = A (\k -> f ^<< g k) 169 | {-# INLINE rmap #-} 170 | 171 | type instance AlgebraType0 A f = () 172 | type instance AlgebraType A c = Arrow c 173 | 174 | instance FreeAlgebra2 A where 175 | liftFree2 = \fab -> A $ \k -> k fab 176 | {-# INLINE liftFree2 #-} 177 | 178 | foldNatFree2 fun (A f) = f fun 179 | {-# INLINE foldNatFree2 #-} 180 | 181 | codom2 = Proof 182 | forget2 = Proof 183 | 184 | data Choice f a b where 185 | NoChoice :: f a b 186 | -> Choice f a b 187 | 188 | Choose :: ArrChoice f a c 189 | -> ArrChoice f b c 190 | -> Choice f (Either a b) c 191 | 192 | type ArrChoice f a b = Arr (Choice f) a b 193 | 194 | instance ArrowChoice (Arr (Choice f)) where 195 | f +++ g = liftArr $ Choose (f >>> arr Left) (g >>> arr Right) 196 | 197 | liftArrChoice :: f a b 198 | -> ArrChoice f a b 199 | liftArrChoice = liftArr . NoChoice 200 | 201 | foldArrChoice :: forall f arr a b. 202 | ArrowChoice arr 203 | => (forall x y. f x y -> arr x y) 204 | -> ArrChoice f a b 205 | -> arr a b 206 | foldArrChoice fun = foldArr fun' 207 | where 208 | fun' :: Choice f x y -> arr x y 209 | fun' (NoChoice f) = fun f 210 | fun' (Choose f g) = foldArrChoice fun f ||| foldArrChoice fun g 211 | -------------------------------------------------------------------------------- /src/Control/Category/Free.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE InstanceSigs #-} 7 | {-# LANGUAGE PatternSynonyms #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE ViewPatterns #-} 14 | {-# LANGUAGE QuantifiedConstraints #-} 15 | 16 | {-# OPTIONS_HADDOCK show-extensions #-} 17 | 18 | module Control.Category.Free 19 | ( -- * Real time Queue 20 | Queue (ConsQ, NilQ) 21 | , consQ 22 | , snocQ 23 | , unconsQ 24 | , liftQ 25 | , foldNatQ 26 | , foldrQ 27 | , foldlQ 28 | , zipWithQ 29 | 30 | -- * Type aligned list 31 | , ListTr (..) 32 | , liftL 33 | , foldNatL 34 | , foldlL 35 | , foldrL 36 | , zipWithL 37 | 38 | -- * Free category (CPS style) 39 | , C (..) 40 | , liftC 41 | , consC 42 | , foldNatC 43 | , toC 44 | , fromC 45 | 46 | -- * Opposite category 47 | , Op (..) 48 | , hoistOp 49 | 50 | -- * Free interface re-exports 51 | , FreeAlgebra2 (..) 52 | , wrapFree2 53 | , foldFree2 54 | , hoistFree2 55 | , hoistFreeH2 56 | , joinFree2 57 | , bindFree2 58 | ) 59 | where 60 | 61 | import Prelude hiding (id, concat, (.)) 62 | import Control.Category (Category (..)) 63 | import Control.Algebra.Free2 64 | ( AlgebraType0 65 | , AlgebraType 66 | , FreeAlgebra2 (..) 67 | , Proof (..) 68 | , wrapFree2 69 | , foldFree2 70 | , hoistFree2 71 | , hoistFreeH2 72 | , joinFree2 73 | , bindFree2 74 | ) 75 | import Control.Arrow (Arrow (..), ArrowZero (..), ArrowChoice (..)) 76 | import Data.Kind (Type) 77 | 78 | import Control.Category.Free.Internal 79 | 80 | 81 | -- 82 | -- CPS style free categories 83 | -- 84 | 85 | -- | CPS style encoded free category; one can use @'FreeAlgebra2'@ class 86 | -- instance: 87 | -- 88 | -- > liftFree2 @C :: f a b -> C f a b 89 | -- > foldNatFree2 @C :: Category d 90 | -- > => (forall x y. f x y -> d x y) 91 | -- > -> C f a b -> d a b 92 | -- 93 | newtype C f a b 94 | = C { runC :: forall r. Category r 95 | => (forall x y. f x y -> r x y) 96 | -> r a b 97 | } 98 | 99 | composeC :: C f y z -> C f x y -> C f x z 100 | composeC (C g) (C f) = C $ \k -> g k . f k 101 | {-# INLINE [1] composeC #-} 102 | 103 | -- | Isomorphism from @'ListTr'@ to @'C'@, which is a specialisation of 104 | -- @'hoistFreeH2'@. 105 | -- 106 | toC :: ListTr f a b -> C f a b 107 | toC = hoistFreeH2 108 | {-# INLINE toC #-} 109 | 110 | -- | Inverse of @'fromC'@, which also is a specialisation of @'hoistFreeH2'@. 111 | -- 112 | fromC :: C f a b -> ListTr f a b 113 | fromC = hoistFreeH2 114 | {-# INLINE fromC #-} 115 | 116 | liftC :: forall k (f :: k -> k -> Type) a b. 117 | f a b 118 | -> C f a b 119 | liftC = \f -> C $ \k -> k f 120 | {-# INLINE [1] liftC #-} 121 | 122 | consC :: forall k (f :: k -> k -> Type) a b c. 123 | f b c 124 | -> C f a b 125 | -> C f a c 126 | consC bc ab = liftC bc `composeC` ab 127 | {-# INLINE [1] consC #-} 128 | 129 | foldNatC :: forall k (f :: k -> k -> Type) c a b. 130 | Category c 131 | => (forall x y. f x y -> c x y) 132 | -> C f a b 133 | -> c a b 134 | foldNatC nat (C f) = f nat 135 | {-# INLINE [1] foldNatC #-} 136 | 137 | {-# RULES 138 | 139 | "foldNatC/consC" 140 | forall (f :: f (v :: k) (w :: k)) 141 | (q :: C f (u :: k) (v :: k)) 142 | (nat :: forall (x :: k) (y :: k). f x y -> c x y). 143 | foldNatC nat (consC f q) = nat f . foldNatC nat q 144 | 145 | "foldNatC/liftC" 146 | forall (nat :: forall (x :: k) (y :: k). f x y -> c x y) 147 | (g :: f v w) 148 | (h :: C f u v). 149 | foldNatC nat (liftC g `composeC` h) = nat g . foldNatC nat h 150 | 151 | #-} 152 | 153 | instance Category (C f) where 154 | id = C (\_ -> id) 155 | (.) = composeC 156 | 157 | -- | Show instance via 'ListTr' 158 | -- 159 | instance (forall x y. Show (f x y)) => Show (C f a b) where 160 | show c = show (hoistFreeH2 c :: ListTr f a b) 161 | 162 | type instance AlgebraType0 C f = () 163 | type instance AlgebraType C c = Category c 164 | 165 | instance FreeAlgebra2 C where 166 | liftFree2 = liftC 167 | {-# INLINE liftFree2 #-} 168 | foldNatFree2 = foldNatC 169 | {-# INLINE foldNatFree2 #-} 170 | 171 | codom2 = Proof 172 | forget2 = Proof 173 | 174 | instance Arrow f => Arrow (C f) where 175 | arr ab = C $ \k -> k (arr ab) 176 | {-# INLINE arr #-} 177 | 178 | C c1 *** C c2 = C $ \k -> k (c1 id *** c2 id) 179 | {-# INLINE (***) #-} 180 | 181 | instance ArrowZero f => ArrowZero (C f) where 182 | zeroArrow = C $ \k -> k zeroArrow 183 | 184 | instance ArrowChoice f => ArrowChoice (C f) where 185 | C c1 +++ C c2 = C $ \k -> k (c1 id +++ c2 id) 186 | {-# INLINE (+++) #-} 187 | 188 | instance Semigroup (C f o o) where 189 | f <> g = f `composeC` g 190 | 191 | instance Monoid (C f o o) where 192 | mempty = id 193 | -------------------------------------------------------------------------------- /src/Control/Category/Free/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE ViewPatterns #-} 11 | {-# LANGUAGE QuantifiedConstraints #-} 12 | 13 | {-# OPTIONS_HADDOCK show-extensions #-} 14 | 15 | -- | Internal module, contains implementation of type aligned real time queues 16 | -- (C.Okasaki 'Purely Functional Data Structures'). 17 | -- 18 | module Control.Category.Free.Internal 19 | ( Op (..) 20 | , hoistOp 21 | 22 | , ListTr (..) 23 | , liftL 24 | , foldNatL 25 | , lengthListTr 26 | , foldrL 27 | , foldlL 28 | , zipWithL 29 | 30 | , Queue (NilQ, ConsQ) 31 | , liftQ 32 | , nilQ 33 | , consQ 34 | , ViewL (..) 35 | , unconsQ 36 | , snocQ 37 | , foldNatQ 38 | , foldrQ 39 | , foldlQ 40 | , hoistQ 41 | , zipWithQ 42 | ) where 43 | 44 | 45 | import Prelude hiding (id, (.)) 46 | import Control.Arrow 47 | import Control.Category (Category (..)) 48 | import Data.Kind (Type) 49 | 50 | import Control.Algebra.Free2 ( AlgebraType0 51 | , AlgebraType 52 | , FreeAlgebra2 (..) 53 | , Proof (..) 54 | ) 55 | 56 | -- | Opposite category in which arrows from @a@ to @b@ are represented by arrows 57 | -- from @b@ to @a@ in the original category. 58 | -- 59 | newtype Op (f :: k -> k -> Type) (a :: k) (b :: k) = Op { runOp :: f b a } 60 | deriving Show 61 | 62 | -- | 'Op' is an endo-functor of the category of categories. 63 | -- 64 | hoistOp :: forall k 65 | (f :: k -> k -> Type) 66 | (g :: k -> k -> Type) 67 | a b. 68 | (forall x y. f x y -> g x y) 69 | -> Op f a b 70 | -> Op g a b 71 | hoistOp nat (Op ba) = Op (nat ba) 72 | {-# INLINE hoistOp #-} 73 | 74 | instance Category f => Category (Op f) where 75 | id = Op id 76 | Op f . Op g = Op (g . f) 77 | 78 | instance Category f => Semigroup (Op f o o) where 79 | (<>) = (.) 80 | 81 | instance Category f => Monoid (Op f o o) where 82 | mempty = id 83 | 84 | 85 | -- 86 | -- Type aligned list 'ListTr' 87 | -- 88 | 89 | 90 | -- | Simple representation of a free category by using type aligned 91 | -- lists. This is not a surprise as free monoids can be represented by 92 | -- lists (up to laziness) 93 | -- 94 | -- 'ListTr' has @'FreeAlgebra2'@ class instance: 95 | -- 96 | -- > liftFree2 @ListTr :: f a b -> ListTr f ab 97 | -- > foldNatFree2 @ListTr :: Category d 98 | -- > => (forall x y. f x y -> d x y) 99 | -- > -> ListTr f a b 100 | -- > -> d a b 101 | -- 102 | -- The same performance concerns that apply to @'Control.Monad.Free.Free'@ 103 | -- apply to this encoding of a free category. 104 | -- 105 | -- Note that even though this is a naive version, it behaves quite well in 106 | -- simple benchmarks and quite stable regardless of the level of optimisations. 107 | -- 108 | data ListTr :: (k -> k -> Type) -> k -> k -> Type where 109 | NilTr :: ListTr f a a 110 | ConsTr :: f b c -> ListTr f a b -> ListTr f a c 111 | 112 | lengthListTr :: ListTr f a b -> Int 113 | lengthListTr NilTr = 0 114 | lengthListTr (ConsTr _ xs) = 1 + lengthListTr xs 115 | 116 | composeL :: forall k (f :: k -> k -> Type) x y z. 117 | ListTr f y z 118 | -> ListTr f x y 119 | -> ListTr f x z 120 | composeL (ConsTr x xs) ys = ConsTr x (xs . ys) 121 | composeL NilTr ys = ys 122 | {-# INLINE [1] composeL #-} 123 | 124 | liftL :: forall k (f :: k -> k -> Type) x y. 125 | f x y -> ListTr f x y 126 | liftL f = ConsTr f NilTr 127 | {-# INLINE [1] liftL #-} 128 | 129 | foldNatL :: forall k (f :: k -> k -> Type) c a b. 130 | Category c 131 | => (forall x y. f x y -> c x y) 132 | -> ListTr f a b 133 | -> c a b 134 | foldNatL _ NilTr = id 135 | foldNatL fun (ConsTr bc ab) = fun bc . foldNatFree2 fun ab 136 | {-# INLINE [1] foldNatL #-} 137 | 138 | {-# RULES 139 | 140 | "foldNatL/ConsTr" 141 | forall (f :: f (v :: k) (w :: k)) 142 | (q :: ListTr f (u :: k) (v :: k)) 143 | (nat :: forall (x :: k) (y :: k). f x y -> c x y). 144 | foldNatL nat (ConsTr f q) = nat f . foldNatL nat q 145 | 146 | "foldNatL/NilTr" forall (nat :: forall (x :: k) (y :: k). f x y -> c x y). 147 | foldNatL nat NilTr = id 148 | 149 | "foldNatL/liftL" 150 | forall (nat :: forall (x :: k) (y :: k). f x y -> c x y) 151 | (g :: f v w) 152 | (h :: ListTr f u v). 153 | foldNatL nat (liftL g `composeL` h) = nat g . foldNatL nat h 154 | 155 | #-} 156 | 157 | -- | 'foldr' of a 'ListTr' 158 | -- 159 | foldrL :: forall k (f :: k -> k -> Type) c a b d. 160 | (forall x y z. f y z -> c x y -> c x z) 161 | -> c a b 162 | -> ListTr f b d 163 | -> c a d 164 | foldrL _nat ab NilTr = ab 165 | foldrL nat ab (ConsTr xd bx) = nat xd (foldrL nat ab bx) 166 | {-# INLINE [1] foldrL #-} 167 | 168 | -- | 'foldl' of a 'ListTr' 169 | -- 170 | -- TODO: make it strict, like 'foldl''. 171 | -- 172 | foldlL :: forall k (f :: k -> k -> Type) c a b d. 173 | (forall x y z. c y z -> f x y -> c x z) 174 | -> c b d 175 | -> ListTr f a b 176 | -> c a d 177 | foldlL _nat bd NilTr = bd 178 | foldlL nat bd (ConsTr xb ax) = foldlL nat (nat bd xb) ax 179 | 180 | zipWithL :: forall f g a b a' b'. 181 | Category f 182 | => (forall x y x' y'. f x y -> f x' y' -> f (g x x') (g y y')) 183 | -> ListTr f a b 184 | -> ListTr f a' b' 185 | -> ListTr f (g a a') (g b b') 186 | zipWithL fn queueA queueB = case (queueA, queueB) of 187 | (NilTr, NilTr) -> NilTr 188 | (NilTr, ConsTr trB' queueB') -> ConsTr (id `fn` trB') (zipWithL fn NilTr queueB') 189 | (ConsTr trA' queueA', NilTr) -> ConsTr (trA' `fn` id) (zipWithL fn queueA' NilTr) 190 | (ConsTr trA' queueA', ConsTr trB' queueB') 191 | -> ConsTr (trA' `fn` trB') (zipWithL fn queueA' queueB') 192 | 193 | instance (forall (x :: k) (y :: k). Show (f x y)) => Show (ListTr f a b) where 194 | show NilTr = "NilTr" 195 | show (ConsTr x xs) = "ConsTr " ++ show x ++ " " ++ show xs 196 | 197 | instance Category (ListTr f) where 198 | id = NilTr 199 | (.) = composeL 200 | 201 | type instance AlgebraType0 ListTr f = () 202 | type instance AlgebraType ListTr c = Category c 203 | 204 | instance FreeAlgebra2 ListTr where 205 | liftFree2 = liftL 206 | {-# INLINE liftFree2 #-} 207 | foldNatFree2 = foldNatL 208 | {-# INLINE foldNatFree2 #-} 209 | 210 | codom2 = Proof 211 | forget2 = Proof 212 | 213 | instance Semigroup (ListTr f o o) where 214 | f <> g = g . f 215 | 216 | instance Monoid (ListTr f o o) where 217 | mempty = NilTr 218 | 219 | instance Arrow f => Arrow (ListTr f) where 220 | arr ab = arr ab `ConsTr` NilTr 221 | 222 | (ConsTr fxb cax) *** (ConsTr fyb cay) 223 | = (fxb *** fyb) `ConsTr` (cax *** cay) 224 | (ConsTr fxb cax) *** NilTr = (fxb *** arr id) `ConsTr` (cax *** NilTr) 225 | NilTr *** (ConsTr fxb cax) = (arr id *** fxb) `ConsTr` (NilTr *** cax) 226 | NilTr *** NilTr = NilTr 227 | 228 | instance ArrowZero f => ArrowZero (ListTr f) where 229 | zeroArrow = zeroArrow `ConsTr` NilTr 230 | 231 | instance ArrowChoice f => ArrowChoice (ListTr f) where 232 | (ConsTr fxb cax) +++ (ConsTr fyb cay) 233 | = (fxb +++ fyb) `ConsTr` (cax +++ cay) 234 | (ConsTr fxb cax) +++ NilTr = (fxb +++ arr id) `ConsTr` (cax +++ NilTr) 235 | NilTr +++ (ConsTr fxb cax) = (arr id +++ fxb) `ConsTr` (NilTr +++ cax) 236 | NilTr +++ NilTr = NilTr 237 | 238 | 239 | -- 240 | -- Type aligned real time 'Queue' 241 | -- 242 | 243 | 244 | -- | Type aligned real time queues; Based on `Purely Functional Data Structures` 245 | -- C.Okasaki. This the most reliably behaved implementation of free categories 246 | -- in this package. 247 | -- 248 | -- Upper bounds of `consQ`, `snocQ`, `unconsQ` are @O\(1\)@ (worst case). 249 | -- 250 | -- Internal invariant: sum of lengths of two last least is equal the length of 251 | -- the first one. 252 | -- 253 | data Queue (f :: k -> k -> Type) (a :: k) (b :: k) where 254 | Queue :: forall f a c b x. 255 | ListTr f b c 256 | -> !(ListTr (Op f) b a) 257 | -> ListTr f b x 258 | -> Queue f a c 259 | 260 | pattern ConsQ :: f b c -> Queue f a b -> Queue f a c 261 | pattern ConsQ a as <- (unconsQ -> a :< as) where 262 | ConsQ = consQ 263 | 264 | pattern NilQ :: () => a ~ b => Queue f a b 265 | pattern NilQ <- (unconsQ -> EmptyL) where 266 | NilQ = nilQ 267 | 268 | {-# complete NilQ, ConsQ #-} 269 | 270 | composeQ :: forall k (f :: k -> k -> Type) x y z. 271 | Queue f y z 272 | -> Queue f x y 273 | -> Queue f x z 274 | composeQ (ConsQ f q1) q2 = ConsQ f (q1 . q2) 275 | composeQ NilQ q2 = q2 276 | {-# INLINE [1] composeQ #-} 277 | 278 | nilQ :: Queue (f :: k -> k -> Type) a a 279 | nilQ = Queue NilTr NilTr NilTr 280 | {-# INLINE [1] nilQ #-} 281 | 282 | consQ :: forall k (f :: k -> k -> Type) a b c. 283 | f b c 284 | -> Queue f a b 285 | -> Queue f a c 286 | consQ bc (Queue f r s) = Queue (ConsTr bc f) r (ConsTr undefined s) 287 | {-# INLINE [1] consQ #-} 288 | 289 | data ViewL f a b where 290 | EmptyL :: ViewL f a a 291 | (:<) :: f b c -> Queue f a b -> ViewL f a c 292 | 293 | -- | 'uncons' a 'Queue', complexity: @O\(1\)@ 294 | -- 295 | unconsQ :: Queue f a b 296 | -> ViewL f a b 297 | unconsQ (Queue NilTr NilTr _) = EmptyL 298 | unconsQ (Queue (ConsTr tr f) r s) = tr :< exec f r s 299 | unconsQ _ = error "Queue.uncons: invariant violation" 300 | {-# INLINE unconsQ #-} 301 | 302 | snocQ :: forall k (f :: k -> k -> Type) a b c. 303 | Queue f b c 304 | -> f a b 305 | -> Queue f a c 306 | snocQ (Queue f r s) g = exec f (ConsTr (Op g) r) s 307 | {-# INLINE snocQ #-} 308 | 309 | -- | 'foldr' of a 'Queue' 310 | -- 311 | foldrQ :: forall k (f :: k -> k -> Type) c a b d. 312 | (forall x y z. f y z -> c x y -> c x z) 313 | -> c a b 314 | -> Queue f b d 315 | -> c a d 316 | foldrQ _nat ab NilQ = ab 317 | foldrQ nat ab (ConsQ xd bx) = nat xd (foldrQ nat ab bx) 318 | {-# INLINE [1] foldrQ #-} 319 | 320 | {-# RULES 321 | 322 | "foldrQ/consQ/nilQ" 323 | foldrQ consQ nilQ = id 324 | 325 | "foldrQ/single" 326 | forall (nat :: forall (x :: k) (y :: k) (z :: k). f y z -> c x y -> c x z) 327 | (t :: f (v :: k) (w :: k)) 328 | (nil :: c (u :: k) (v :: k)). 329 | foldrQ nat nil (consQ t nilQ) = nat t nil 330 | 331 | "foldrQ/nilQ" 332 | forall (nat :: forall (x :: k) (y :: k) (z :: k). f y z -> c x y -> c x z) 333 | (nil :: c (u :: k) (v :: k)). 334 | foldrQ nat nil nilQ = nil 335 | 336 | "foldrQ/consQ" 337 | forall (f :: Queue f (x :: k) (y :: k)) 338 | (g :: Queue f (y :: k) (z :: k)). 339 | foldrQ consQ f g = g . f 340 | 341 | #-} 342 | 343 | liftQ :: forall k (f :: k -> k -> Type) a b. 344 | f a b -> Queue f a b 345 | liftQ = \fab -> ConsQ fab NilQ 346 | {-# INLINE [1] liftQ #-} 347 | 348 | -- | Efficient fold of a queue into a category, analogous to 'foldM'. 349 | -- 350 | -- /complexity/ @O\(n\)@ 351 | -- 352 | foldNatQ :: forall k (f :: k -> k -> Type) c a b. 353 | Category c 354 | => (forall x y. f x y -> c x y) 355 | -> Queue f a b 356 | -> c a b 357 | foldNatQ nat = foldrQ (\f c -> nat f . c) id 358 | {-# INLINE [1] foldNatQ #-} 359 | 360 | {-# RULES 361 | 362 | "foldNatQ/consQ" forall (f :: f (v :: k) (w :: k)) 363 | (q :: Queue f (u :: k) (v :: k)) 364 | (nat :: forall (x :: k) (y :: k). f x y -> c x y). 365 | foldNatQ nat (consQ f q) = nat f . foldNatQ nat q 366 | 367 | "foldNatQ/nilQ" forall (nat :: forall (x :: k) (y :: k). f x y -> c x y). 368 | foldNatQ nat nilQ = id 369 | 370 | 371 | "foldNatC/liftQ" 372 | forall (nat :: forall (x :: k) (y :: k). f x y -> c x y) 373 | (g :: f v w) 374 | (h :: Queue f u v). 375 | foldNatQ nat (liftQ g `composeQ` h) = nat g . foldNatQ nat h 376 | 377 | #-} 378 | 379 | -- | 'foldl' of a 'Queue' 380 | -- 381 | -- TODO: make it strict, like 'foldl''. 382 | -- 383 | foldlQ :: forall k (f :: k -> k -> Type) c a b d. 384 | (forall x y z. c y z -> f x y -> c x z) 385 | -> c b d 386 | -> Queue f a b 387 | -> c a d 388 | foldlQ _nat bd NilQ = bd 389 | foldlQ nat bd (ConsQ xb ax) = foldlQ nat (nat bd xb) ax 390 | 391 | zipWithQ :: forall f g a b a' b'. 392 | Category f 393 | => (forall x y x' y'. f x y -> f x' y' -> f (g x x') (g y y')) 394 | -> Queue f a b 395 | -> Queue f a' b' 396 | -> Queue f (g a a') (g b b') 397 | zipWithQ fn queueA queueB = case (queueA, queueB) of 398 | (NilQ, NilQ) -> NilQ 399 | (NilQ, ConsQ trB' queueB') -> ConsQ (id `fn` trB') (zipWithQ fn NilQ queueB') 400 | (ConsQ trA' queueA', NilQ) -> ConsQ (trA' `fn` id) (zipWithQ fn queueA' NilQ) 401 | (ConsQ trA' queueA', ConsQ trB' queueB') 402 | -> ConsQ (trA' `fn` trB') (zipWithQ fn queueA' queueB') 403 | 404 | 405 | -- | 'Queue' is an endo-functor on the category of graphs (or category of 406 | -- categories), thus one can hoist the transitions using a natural 407 | -- transformation. This in analogy to @'map' :: (a -> b) -> [a] -> [b]@. 408 | -- 409 | hoistQ :: forall k 410 | (f :: k -> k -> Type) 411 | (g :: k -> k -> Type) 412 | a b. 413 | (forall x y. f x y -> g x y) 414 | -> Queue f a b 415 | -> Queue g a b 416 | hoistQ nat q = case q of 417 | NilQ -> NilQ 418 | ConsQ tr q' -> ConsQ (nat tr) (hoistQ nat q') 419 | {-# INLINE [1] hoistQ #-} 420 | 421 | {-# RULES 422 | 423 | "hoistQ/foldNatQ" 424 | forall (nat1 :: forall (x :: k) (y :: k). f x y -> g x y) 425 | (nat :: forall (x :: k) (y :: k). g x y -> h x y) 426 | (q :: Queue f x y). 427 | foldNatQ nat (hoistQ nat1 q) = foldNatQ (nat . nat1) q 428 | 429 | "hoistQ/hoistQ" 430 | forall (nat1 :: forall (x :: k) (y :: k). f x y -> g x y) 431 | (nat :: forall (x :: k) (y :: k). g x y -> h x y) 432 | (q :: Queue f x y). 433 | hoistQ nat (hoistQ nat1 q) = hoistQ (nat . nat1) q 434 | 435 | #-} 436 | 437 | instance (forall (x :: k) (y :: k). Show (f x y)) 438 | => Show (Queue f a b) where 439 | show (Queue f r s) = 440 | "Queue (" 441 | ++ show f 442 | ++ ") (" 443 | ++ show r 444 | ++ ") " 445 | ++ show (lengthListTr s) 446 | 447 | instance Category (Queue f) where 448 | id = NilQ 449 | (.) = composeQ 450 | 451 | type instance AlgebraType0 Queue f = () 452 | type instance AlgebraType Queue c = Category c 453 | 454 | instance FreeAlgebra2 Queue where 455 | liftFree2 = liftQ 456 | {-# INLINE liftFree2 #-} 457 | foldNatFree2 = foldNatQ 458 | {-# INLINE foldNatFree2 #-} 459 | 460 | codom2 = Proof 461 | forget2 = Proof 462 | 463 | instance Semigroup (Queue f o o) where 464 | f <> g = g `composeQ` f 465 | 466 | instance Monoid (Queue f o o) where 467 | mempty = NilQ 468 | #if __GLASGOW_HASKELL__ < 804 469 | mappend = (<>) 470 | #endif 471 | 472 | instance Arrow f => Arrow (Queue f) where 473 | arr ab = arr ab `ConsQ` NilQ 474 | 475 | (ConsQ fxb cax) *** (ConsQ fyb cay) 476 | = (fxb *** fyb) `ConsQ` (cax *** cay) 477 | (ConsQ fxb cax) *** NilQ = (fxb *** arr id) `ConsQ` (cax *** NilQ) 478 | NilQ *** (ConsQ fxb cax) = (arr id *** fxb) `ConsQ` (NilQ *** cax) 479 | NilQ *** NilQ = NilQ 480 | 481 | instance ArrowZero f => ArrowZero (Queue f) where 482 | zeroArrow = zeroArrow `ConsQ` NilQ 483 | 484 | instance ArrowChoice f => ArrowChoice (Queue f) where 485 | (ConsQ fxb cax) +++ (ConsQ fyb cay) 486 | = (fxb +++ fyb) `ConsQ` (cax +++ cay) 487 | (ConsQ fxb cax) +++ NilQ = (fxb +++ arr id) `ConsQ` (cax +++ NilQ) 488 | NilQ +++ (ConsQ fxb cax) = (arr id +++ fxb) `ConsQ` (NilQ +++ cax) 489 | NilQ +++ NilQ = NilQ 490 | 491 | -- 492 | -- Internal API 493 | -- 494 | 495 | exec :: ListTr f b c -> ListTr (Op f) b a -> ListTr f b x -> Queue f a c 496 | exec xs ys (ConsTr _ t) = Queue xs ys t 497 | exec xs ys NilTr = Queue xs' NilTr xs' 498 | where 499 | xs' = rotate xs ys NilTr 500 | {-# INLINABLE exec #-} 501 | 502 | rotate :: ListTr f c d -> ListTr (Op f) c b -> ListTr f a b -> ListTr f a d 503 | rotate NilTr (ConsTr (Op f) NilTr) a = ConsTr f a 504 | rotate (ConsTr f fs) (ConsTr (Op g) gs) a = ConsTr f (rotate fs gs (ConsTr g a)) 505 | rotate _ _ _ = error "Queue.rotate: impossible happend" 506 | -------------------------------------------------------------------------------- /src/Control/Category/FreeEffect.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | {-# OPTIONS_HADDOCK show-extensions #-} 9 | 10 | module Control.Category.FreeEffect 11 | ( EffectCategory (..) 12 | , EffCat (..) 13 | , liftEffect 14 | , foldNatEffCat 15 | , runEffCat 16 | , liftKleisli 17 | ) where 18 | 19 | import Prelude hiding (id, (.)) 20 | 21 | import Control.Arrow (Kleisli (..)) 22 | import Control.Category (Category (..)) 23 | import Data.Functor.Identity (Identity (..)) 24 | import Data.Kind (Type) 25 | 26 | import Control.Algebra.Free2 (FreeAlgebra2 (..)) 27 | import Data.Algebra.Free (AlgebraType, AlgebraType0, Proof (..)) 28 | 29 | 30 | -- | Categories which can lift monadic actions, i.e effectful categories. 31 | -- 32 | class Category c => EffectCategory c m | c -> m where 33 | effect :: m (c a b) -> c a b 34 | 35 | instance Monad m => EffectCategory (Kleisli m) m where 36 | effect m = Kleisli (\a -> m >>= \(Kleisli f) -> f a) 37 | 38 | instance EffectCategory (->) Identity where 39 | effect = runIdentity 40 | 41 | -- | Category transformer, which adds @'EffectCategory'@ instance to the 42 | -- underlying base category. 43 | -- 44 | data EffCat :: (Type -> Type) -> (k -> k -> Type) -> k -> k -> Type where 45 | Base :: c a b -> EffCat m c a b 46 | Effect :: m (EffCat m c a b) -> EffCat m c a b 47 | 48 | instance (Functor m, Category c) => Category (EffCat m c) where 49 | id = Base id 50 | Base f . Base g = Base $ f . g 51 | f . Effect mg = Effect $ (f .) <$> mg 52 | Effect mf . g = Effect $ (. g) <$> mf 53 | 54 | instance (Functor m, Category c) => EffectCategory (EffCat m c) m where 55 | effect = Effect 56 | 57 | type instance AlgebraType0 (EffCat m) c = (Monad m, Category c) 58 | type instance AlgebraType (EffCat m) c = EffectCategory c m 59 | instance Monad m => FreeAlgebra2 (EffCat m) where 60 | liftFree2 = Base 61 | foldNatFree2 nat (Base cab) = nat cab 62 | foldNatFree2 nat (Effect mcab) = effect $ foldNatFree2 nat <$> mcab 63 | 64 | codom2 = Proof 65 | forget2 = Proof 66 | 67 | -- | Wrap a transition into @'EffCat' cat@ for any free category 'cat' (e.g. 68 | -- 'Cat'). 69 | -- 70 | liftEffect :: ( Monad m 71 | , FreeAlgebra2 cat 72 | , AlgebraType0 cat tr 73 | , Category (cat tr) 74 | ) 75 | => tr a b -> EffCat m (cat tr) a b 76 | liftEffect = liftFree2 . liftFree2 77 | 78 | -- | Fold @'FreeLifting'@ category based on a free category @'cat' tr@ (e.g. 79 | -- @'C' tr@) using a functor @tr x y -> c x y@. 80 | -- 81 | foldNatEffCat 82 | :: ( Monad m 83 | , FreeAlgebra2 cat 84 | , AlgebraType cat c 85 | , AlgebraType0 cat tr 86 | , Category (cat tr) 87 | , EffectCategory c m 88 | ) 89 | => (forall x y. tr x y -> c x y) 90 | -> EffCat m (cat tr) a b 91 | -> c a b 92 | foldNatEffCat nat = foldNatFree2 (foldNatFree2 nat) 93 | 94 | -- | Join all effects in a free effectful category 'EffCat'. 95 | -- 96 | runEffCat 97 | :: Monad m 98 | => EffCat m c a b 99 | -> m (c a b) 100 | runEffCat (Base f) = return f 101 | runEffCat (Effect mf) = runEffCat =<< mf 102 | 103 | -- | Functor from @(->)@ category to @'Kleisli' m@. If @m@ is 'Identity' then 104 | -- it will respect 'effect' i.e. 105 | -- @'liftKleisli' ('effect' ar) = 'effect' ('liftKleisli' \<$\> ar)@. 106 | -- 107 | liftKleisli :: Applicative m => (a -> b) -> Kleisli m a b 108 | liftKleisli f = Kleisli (pure . f) 109 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.Tasty 4 | 5 | import qualified Test.Queue 6 | import qualified Test.Cat 7 | 8 | main :: IO () 9 | main = defaultMain tests 10 | 11 | tests :: TestTree 12 | tests = 13 | testGroup "free-categories" 14 | -- data structures 15 | [ Test.Queue.tests 16 | , Test.Cat.tests 17 | ] 18 | -------------------------------------------------------------------------------- /test/Test/Cat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | #if __GLASGOW_HASKELL__ >= 902 5 | {-# LANGUAGE FlexibleContexts #-} 6 | #endif 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE KindSignatures #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TupleSections #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | {-# LANGUAGE QuantifiedConstraints #-} 15 | 16 | {-# OPTIONS_GHC -Wno-orphans #-} 17 | 18 | module Test.Cat (tests) where 19 | 20 | import Prelude hiding ((.), id) 21 | import Control.Category 22 | import Data.Function (on) 23 | import Text.Show.Functions () 24 | import Numeric.Natural (Natural) 25 | 26 | import Control.Algebra.Free2 27 | import Control.Category.Free 28 | 29 | import Test.QuickCheck 30 | import Test.Tasty (TestTree, testGroup) 31 | import Test.Tasty.QuickCheck (testProperty) 32 | 33 | tests :: TestTree 34 | tests = 35 | testGroup "Control.Category.Free" 36 | [ testProperty "Queue" prop_Queue 37 | , testProperty "C" prop_C 38 | , testGroup "Category laws" 39 | [ testProperty "ListTr id" prop_id_ListTr 40 | , testProperty "ListTr associativity" prop_associativity_ListTr 41 | , testProperty "Queue id" prop_id_Queue 42 | , testProperty "Queue associativity" prop_associativity_Queue 43 | , testProperty "C id" prop_id_C 44 | , testProperty "C associativity" prop_associativity_C 45 | ] 46 | , testGroup "foldFree2 and foldMap" 47 | [ testProperty "foldFree ListTr" prop_foldListTr 48 | , testProperty "foldFree Queue" prop_foldQueue 49 | , testProperty "foldFree C" prop_foldC 50 | ] 51 | ] 52 | 53 | 54 | data Tr a b where 55 | -- Num transition 56 | NumTr :: Num a => (a -> a) -> Tr a a 57 | FromInteger :: Num b => Tr Integer b 58 | 59 | -- Integral transition 60 | ToInteger :: Integral a => Tr a Integer 61 | 62 | 63 | interpretTr :: Tr a b -> a -> b 64 | interpretTr (NumTr f) = f 65 | interpretTr FromInteger = fromInteger 66 | interpretTr ToInteger = toInteger 67 | 68 | 69 | instance (Show a, Show b) => Show (Tr a b) where 70 | show (NumTr f) = "NumTr " ++ show f 71 | show FromInteger = "FromInteger" 72 | show ToInteger = "ToInteger" 73 | 74 | 75 | data SomeNumTr f a where 76 | SomeNumTr :: Num a 77 | => f Tr a a 78 | -> SomeNumTr f a 79 | 80 | instance Show (f Tr a a) => Show (SomeNumTr f a) where 81 | show (SomeNumTr f) = "SomeNumTr " ++ show f 82 | 83 | 84 | data SomeIntegralTr f a where 85 | SomeIntegralTr :: Integral a 86 | => f Tr a a 87 | -> SomeIntegralTr f a 88 | 89 | instance Show (f Tr a a) => Show (SomeIntegralTr f a) where 90 | show (SomeIntegralTr f) = "SomeIntegralTr " ++ show f 91 | 92 | 93 | -- A 'fromIntegral' transition in any free category @f@. 94 | fromIntegralTr :: ( Integral a 95 | , Num b 96 | , Category (f Tr) 97 | , AlgebraType0 f Tr 98 | , FreeAlgebra2 f 99 | ) => f Tr a b 100 | fromIntegralTr = liftFree2 FromInteger . liftFree2 ToInteger 101 | 102 | 103 | data Sing a where 104 | SInt :: Sing Int 105 | SInteger :: Sing Integer 106 | SNatural :: Sing Natural 107 | 108 | instance Show (Sing a) where 109 | show SInt = "SInt" 110 | show SInteger = "SInteger" 111 | show SNatural = "SNatural" 112 | 113 | data AnySing where 114 | AnySing :: Eq a => Sing a -> AnySing 115 | 116 | instance Eq AnySing where 117 | AnySing SInt == AnySing SInt = True 118 | AnySing SInteger == AnySing SInteger = True 119 | AnySing SNatural == AnySing SNatural = True 120 | _ == _ = False 121 | 122 | instance Show AnySing where 123 | show (AnySing sing) = show sing 124 | 125 | instance Arbitrary AnySing where 126 | arbitrary = oneof 127 | [ pure $ AnySing SInt 128 | , pure $ AnySing SInteger 129 | , pure $ AnySing SNatural 130 | ] 131 | 132 | 133 | instance Arbitrary Natural where 134 | arbitrary = 135 | fromIntegral . getPositive <$> (arbitrary :: Gen (Positive Integer)) 136 | 137 | instance CoArbitrary Natural where 138 | coarbitrary a = variant (fromIntegral a :: Int) 139 | 140 | data AnyListTr b where 141 | AnyListTr :: Eq c => ListTr Tr b c -> Sing c -> AnyListTr b 142 | 143 | 144 | genNextTr :: Sing b 145 | -> Gen (AnyListTr b) 146 | genNextTr b = do 147 | AnySing c <- arbitrary 148 | case (b, c) of 149 | (SInt, SInt) -> 150 | (\f -> AnyListTr (ConsTr (NumTr f) NilTr) c) <$> arbitrary 151 | (SInteger, SInteger) -> 152 | (\f -> AnyListTr (ConsTr (NumTr f) NilTr) c) <$> arbitrary 153 | (SNatural, SNatural) -> 154 | (\f -> AnyListTr (ConsTr (NumTr f) NilTr) c) <$> arbitrary 155 | 156 | (SInt, SInteger) -> 157 | pure $ AnyListTr fromIntegralTr c 158 | (SInt, SNatural) -> 159 | pure $ AnyListTr (fromIntegralTr . liftFree2 (NumTr abs)) c 160 | (SInteger, SInt) -> 161 | pure $ AnyListTr fromIntegralTr c 162 | (SNatural, SInt) -> 163 | pure $ AnyListTr fromIntegralTr c 164 | (SNatural, SInteger) -> 165 | pure $ AnyListTr fromIntegralTr c 166 | (SInteger, SNatural) -> 167 | pure $ AnyListTr (fromIntegralTr . liftFree2 (NumTr abs)) c 168 | 169 | 170 | data ArbListTr where 171 | ArbListTr :: Eq b => ListTr Tr a b -> Sing a -> Sing b -> ArbListTr 172 | 173 | instance (forall x y. Show (Tr x y)) => Show ArbListTr where 174 | show (ArbListTr listTr a b) = 175 | "ArbListTr " 176 | ++ show a 177 | ++ " -> " 178 | ++ show b 179 | ++ " " 180 | ++ show listTr 181 | 182 | instance Arbitrary ArbListTr where 183 | arbitrary = sized $ \n -> do 184 | k <- choose (0, n) 185 | AnySing a <- arbitrary 186 | go k a (AnyListTr NilTr a) 187 | where 188 | go 0 a (AnyListTr ab b) = pure $ ArbListTr ab a b 189 | go n a (AnyListTr ab b) = do 190 | AnyListTr bc c <- genNextTr b 191 | -- (.) can be used as (++) for ListTr 192 | go (n - 1) a $ AnyListTr (bc . ab) c 193 | 194 | 195 | -- 196 | -- test 'Cat' and 'C' treating 'ListTr' as a model to compare to. 197 | -- 198 | prop_Queue, prop_C 199 | :: Blind ArbListTr -> Bool 200 | 201 | 202 | prop_Queue (Blind (ArbListTr listTr SInt _)) = 203 | foldNatFree2 interpretTr (hoistFreeH2 @_ @Queue listTr) 0 204 | == 205 | foldNatFree2 interpretTr listTr 0 206 | prop_Queue (Blind (ArbListTr listTr SInteger _)) = 207 | foldNatFree2 interpretTr (hoistFreeH2 @_ @Queue listTr) 0 208 | == 209 | foldNatFree2 interpretTr listTr 0 210 | prop_Queue (Blind (ArbListTr listTr SNatural _)) = 211 | foldNatFree2 interpretTr (hoistFreeH2 @_ @Queue listTr) 0 212 | == 213 | foldNatFree2 interpretTr listTr 0 214 | 215 | 216 | prop_C (Blind (ArbListTr listTr SInt _)) = 217 | foldNatFree2 interpretTr (hoistFreeH2 @_ @C listTr) 0 218 | == 219 | foldNatFree2 interpretTr listTr 0 220 | prop_C (Blind (ArbListTr listTr SInteger _)) = 221 | foldNatFree2 interpretTr (hoistFreeH2 @_ @C listTr) 0 222 | == 223 | foldNatFree2 interpretTr listTr 0 224 | prop_C (Blind (ArbListTr listTr SNatural _)) = 225 | foldNatFree2 interpretTr (hoistFreeH2 @_ @C listTr) 0 226 | == 227 | foldNatFree2 interpretTr listTr 0 228 | 229 | -- 230 | -- Test Category Laws 231 | -- @ 232 | -- f . id == f == id . f 233 | -- f . g . h == (f . g) . h 234 | -- @ 235 | -- 236 | 237 | prop_id :: Category c 238 | => (c a b -> c a b -> Bool) 239 | -> c a b 240 | -> Bool 241 | prop_id eqCat f = eqCat (f . id) f && eqCat (id . f) f 242 | 243 | prop_associativity :: Category c 244 | => (c x w -> c x w -> Bool) 245 | -> c z w -> c y z -> c x y 246 | -> Bool 247 | prop_associativity eqCat f g h = 248 | (f . g . h) `eqCat` ((f . g) . h) 249 | 250 | 251 | -- | Integers form commutative monoid, and thus a category (a groupoid to be 252 | -- precise) with a single object. 253 | -- 254 | data IntCat (a :: ()) (b :: ()) where 255 | IntCat :: Int -> IntCat a a 256 | 257 | instance Show (IntCat a b) where 258 | show (IntCat i) = "IntCat " ++ show i 259 | 260 | instance Eq (IntCat a b) where 261 | IntCat i == IntCat j = i == j 262 | 263 | instance Category IntCat where 264 | id = IntCat 0 265 | IntCat a . IntCat b = IntCat (a + b) 266 | 267 | instance Semigroup (IntCat '() '()) where 268 | IntCat a <> IntCat b = IntCat (a + b) 269 | 270 | instance Monoid (IntCat '() '()) where 271 | mempty = IntCat 0 272 | 273 | instance Arbitrary (IntCat '() '()) where 274 | arbitrary = IntCat <$> arbitrary 275 | 276 | fromList :: forall k (a :: k) m f. 277 | ( FreeAlgebra2 m 278 | , AlgebraType0 m f 279 | , Category (m f) 280 | ) => [f a a] -> m f a a 281 | fromList [] = id 282 | fromList (f : fs) = liftFree2 f . fromList fs 283 | 284 | toList :: ( FreeAlgebra2 m 285 | , AlgebraType0 m IntCat 286 | , AlgebraType m (ListTr IntCat) 287 | ) 288 | => m IntCat '() '() 289 | -> [IntCat '() '()] 290 | toList c = go (hoistFreeH2 c) 291 | where 292 | go :: ListTr IntCat '() '() -> [IntCat '() '()] 293 | go NilTr = [] 294 | go (ConsTr tr@IntCat{} xs) = tr : go xs 295 | 296 | -- 297 | -- 'C' category laws 298 | -- 299 | 300 | newtype ArbIntC = ArbIntC (C IntCat '() '()) 301 | 302 | instance Show ArbIntC where 303 | show (ArbIntC c) = show c 304 | 305 | instance Arbitrary ArbIntC where 306 | arbitrary = ArbIntC . fromList <$> arbitrary 307 | shrink (ArbIntC c) = 308 | map (ArbIntC . fromList) 309 | $ shrinkList (const []) 310 | $ toList c 311 | 312 | prop_id_C :: ArbIntC -> Bool 313 | prop_id_C (ArbIntC f) = 314 | prop_id (on (==) toList) f 315 | 316 | prop_associativity_C 317 | :: ArbIntC -> ArbIntC -> ArbIntC 318 | -> Bool 319 | prop_associativity_C (ArbIntC f0) 320 | (ArbIntC f1) 321 | (ArbIntC f2) = 322 | prop_associativity (on (==) toList) f0 f1 f2 323 | 324 | -- 325 | -- 'Queue' category laws 326 | -- 327 | 328 | newtype ArbIntQueue = ArbIntQueue (Queue IntCat '() '()) 329 | 330 | instance Show ArbIntQueue where 331 | show (ArbIntQueue f) = show (toList f) 332 | 333 | instance Arbitrary ArbIntQueue where 334 | arbitrary = ArbIntQueue . fromList <$> arbitrary 335 | shrink (ArbIntQueue c) = 336 | map (ArbIntQueue . fromList) 337 | $ shrinkList (const []) 338 | $ toList c 339 | 340 | prop_id_Queue :: ArbIntQueue -> Bool 341 | prop_id_Queue (ArbIntQueue f) = 342 | prop_id (on (==) toList) f 343 | 344 | prop_associativity_Queue 345 | :: ArbIntQueue -> ArbIntQueue -> ArbIntQueue 346 | -> Bool 347 | prop_associativity_Queue (ArbIntQueue f0) 348 | (ArbIntQueue f1) 349 | (ArbIntQueue f2) = 350 | prop_associativity (on (==) toList) f0 f1 f2 351 | 352 | -- 353 | -- 'ListTr' category laws 354 | -- 355 | 356 | newtype ArbIntListTr = ArbIntListTr (ListTr IntCat '() '()) 357 | 358 | instance Show ArbIntListTr where 359 | show (ArbIntListTr f) = show (toList f) 360 | 361 | instance Arbitrary ArbIntListTr where 362 | arbitrary = ArbIntListTr . fromList <$> arbitrary 363 | shrink (ArbIntListTr c) = 364 | map (ArbIntListTr . fromList) 365 | $ shrinkList (const []) 366 | $ toList c 367 | 368 | prop_id_ListTr :: ArbIntListTr -> Bool 369 | prop_id_ListTr (ArbIntListTr f) = 370 | prop_id (on (==) toList) f 371 | 372 | prop_associativity_ListTr 373 | :: ArbIntListTr -> ArbIntListTr -> ArbIntListTr 374 | -> Bool 375 | prop_associativity_ListTr (ArbIntListTr f0) 376 | (ArbIntListTr f1) 377 | (ArbIntListTr f2) = 378 | prop_associativity (on (==) toList) f0 f1 f2 379 | 380 | 381 | -- 382 | -- Compatibility between 'foldFree2' and 'foldMap' for 'IntCat' 383 | -- 384 | 385 | prop_foldListTr :: ArbIntListTr -> Bool 386 | prop_foldListTr (ArbIntListTr f) 387 | = foldFree2 f == foldMap id (toList f) 388 | 389 | prop_foldQueue :: ArbIntQueue -> Bool 390 | prop_foldQueue (ArbIntQueue f) 391 | = foldFree2 f == foldMap id (toList f) 392 | 393 | prop_foldC :: (Blind ArbIntC) -> Bool 394 | prop_foldC (Blind (ArbIntC f)) 395 | = foldFree2 f == foldMap id (toList f) 396 | -------------------------------------------------------------------------------- /test/Test/Queue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | 9 | module Test.Queue (tests) where 10 | 11 | import Prelude hiding ((.), id) 12 | import Text.Show.Functions () 13 | 14 | import Control.Category.Free.Internal 15 | 16 | import Test.QuickCheck 17 | import Test.Tasty (TestTree, testGroup) 18 | import Test.Tasty.QuickCheck (testProperty) 19 | 20 | tests :: TestTree 21 | tests = 22 | testGroup "Queue" 23 | [ testProperty "consQ" prop_consQ 24 | , testProperty "unconsQ" prop_unconsQ 25 | , testProperty "snocQ" prop_snocQ 26 | , testProperty "foldrQ" (prop_foldr @Int) 27 | , testProperty "foldrQ" (prop_foldl @Int) 28 | ] 29 | 30 | data K = K 31 | 32 | data Tr (a :: K) (b :: K) where 33 | A :: Int -> Tr 'K 'K 34 | 35 | instance Eq (Tr 'K 'K) where 36 | A i == A j = i == j 37 | 38 | instance Show (Tr a b) where 39 | show (A i) = "A " ++ show i 40 | 41 | instance Arbitrary (Tr 'K 'K) where 42 | arbitrary = A <$> arbitrary 43 | 44 | 45 | toList :: Queue Tr 'K 'K -> [Tr 'K 'K] 46 | toList q = case q of 47 | ConsQ a@A{} as -> a : toList as 48 | _ -> [] 49 | 50 | 51 | fromList :: [Tr 'K 'K] -> Queue Tr 'K 'K 52 | fromList [] = NilQ 53 | fromList (a : as) = ConsQ a (fromList as) 54 | 55 | 56 | instance Arbitrary (Queue Tr 'K 'K) where 57 | arbitrary = fromList <$> arbitrary 58 | shrink q = map fromList $ shrinkList (const []) (toList q) 59 | 60 | 61 | prop_unconsQ :: Queue Tr 'K 'K -> Bool 62 | prop_unconsQ q = 63 | case q of 64 | ConsQ a@A{} _ -> 65 | case as of 66 | a' : _ -> a == a' 67 | [] -> False 68 | NilQ -> null as 69 | where 70 | as = toList q 71 | 72 | 73 | prop_consQ :: Tr 'K 'K -> Queue Tr 'K 'K -> Bool 74 | prop_consQ a@A{} q = case consQ a q of 75 | ConsQ a'@A{} _ -> a' == a' 76 | _ -> False 77 | 78 | 79 | prop_snocQ :: Tr 'K 'K -> Queue Tr 'K 'K -> Bool 80 | prop_snocQ a@A{} q = last (toList (q `snocQ` a)) == a 81 | 82 | 83 | data TrA a (x :: K) (y :: K) where 84 | TrA :: a -> TrA a 'K 'K 85 | 86 | instance Show a => Show (TrA a 'K 'K) where 87 | show (TrA a) = "TrA " ++ show a 88 | 89 | instance Eq a => Eq (TrA a k k) where 90 | TrA a == TrA b = a == b 91 | 92 | instance Arbitrary a => Arbitrary (TrA a 'K 'K) where 93 | arbitrary = TrA <$> arbitrary 94 | shrink (TrA a) = map TrA (shrink a) 95 | 96 | 97 | prop_foldr :: forall a. 98 | Eq a 99 | => (Int -> a -> a) 100 | -> TrA a 'K 'K 101 | -> Queue Tr 'K 'K 102 | -> Bool 103 | prop_foldr f a q = foldrQ g a q == foldr g a (toList q) 104 | where 105 | g :: Tr y z-> TrA a x y -> TrA a x z 106 | g (A i) (TrA j) = TrA (f i j) 107 | 108 | 109 | prop_foldl :: forall a. 110 | Eq a 111 | => (a -> Int -> a) 112 | -> TrA a 'K 'K 113 | -> Queue Tr 'K 'K 114 | -> Bool 115 | prop_foldl f a q = foldlQ g a q == foldl g a (toList q) 116 | where 117 | g :: TrA a y z-> Tr x y -> TrA a x z 118 | g (TrA j) (A i) = TrA (f j i) 119 | --------------------------------------------------------------------------------